Theory Diagonal_To_Smith
section ‹Algorithm to transform a diagonal matrix into its Smith normal form›
theory Diagonal_To_Smith
imports Hermite.Hermite
"HOL-Types_To_Sets.Types_To_Sets"
Smith_Normal_Form
begin
lemma invertible_mat_1: "invertible (mat (1::'a::comm_ring_1))"
unfolding invertible_iff_is_unit by simp
subsection ‹Implementation of the algorithm›
type_synonym 'a bezout = "'a ⇒ 'a ⇒ 'a × 'a × 'a × 'a × 'a"
hide_const Countable.from_nat
hide_const Countable.to_nat
text ‹The algorithm is based on the one presented by Bradley in his article entitled
``Algorithms for Hermite and Smith normal matrices and linear diophantine equations''.
Some improvements have been introduced to get a general version for any matrix (including
non-square and singular ones).›
text ‹I also introduced another improvement: the element in the position j does not need
to be checked each time, since the element $A_{ii}$ will already divide $A_{jj}$ (where $j \le k$).
The gcd will be placed in $A_{ii}$.›
text ‹This function transforms the element $A_{jj}$ in order to be divisible by $A_{ii}$
(and it changes $A_{ii}$ as well).
The use of @{text "from_nat"} and @{text "from_nat"} is mandatory since the same
index $i$ cannot be used for both rows
and columns at the same time, since they could have different type, concretely,
when the matrix is rectangular.›
text‹The following definition is valid, but since execution requires the trick of converting
all operations in terms of rows, then we would be recalculating the B\'ezout coefficients each time.›
text‹Thus, the definition is parameterized by the necessary elements instead of the operation,
to avoid recalculations.›
definition "diagonal_step A i j d v =
(χ a b. if a = from_nat i ∧ b = from_nat i then d else
if a = from_nat j ∧ b = from_nat j
then v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b)"
fun diagonal_to_Smith_i ::
"nat list ⇒ 'a::{bezout_ring}^'cols::mod_type^'rows::mod_type ⇒ nat ⇒ ('a bezout)
⇒ 'a^'cols::mod_type^'rows::mod_type"
where
"diagonal_to_Smith_i [] A i bezout = A" |
"diagonal_to_Smith_i (j#xs) A i bezout = (
if A $ (from_nat i) $ (from_nat i) dvd A $ (from_nat j) $ (from_nat j)
then diagonal_to_Smith_i xs A i bezout
else let (p, q, u, v, d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j);
A' = diagonal_step A i j d v
in diagonal_to_Smith_i xs A' i bezout
)
"
definition "Diagonal_to_Smith_row_i A i bezout
= diagonal_to_Smith_i [i+1..<min (nrows A) (ncols A)] A i bezout"
fun diagonal_to_Smith_aux :: " 'a::{bezout_ring}^'cols::mod_type^'rows::mod_type
⇒ nat list ⇒ ('a bezout) ⇒ 'a^'cols::mod_type^'rows::mod_type"
where
"diagonal_to_Smith_aux A [] bezout = A" |
"diagonal_to_Smith_aux A (i#xs) bezout
= diagonal_to_Smith_aux (Diagonal_to_Smith_row_i A i bezout) xs bezout"
text‹The minimum arises to include the case of non-square matrices (we do not
demand the input diagonal matrix to be square, just have zeros in non-diagonal entries).
This iteration does not need to be performed until the last element of the diagonal,
because in the second-to-last step the matrix will be already in Smith normal form.›
definition "diagonal_to_Smith A bezout
= diagonal_to_Smith_aux A [0..<min (nrows A) (ncols A) - 1] bezout"
subsection‹Code equations to get an executable version›
definition diagonal_step_row
where "diagonal_step_row A i j c v a = vec_lambda (%b. if a = from_nat i ∧ b = from_nat i then c else
if a = from_nat j ∧ b = from_nat j
then v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b)"
lemma diagonal_step_code [code abstract]:
"vec_nth (diagonal_step_row A i j c v a) = (%b. if a = from_nat i ∧ b = from_nat i then c else
if a = from_nat j ∧ b = from_nat j
then v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b)"
unfolding diagonal_step_row_def by auto
lemma diagonal_step_code_nth [code abstract]: "vec_nth (diagonal_step A i j c v)
= diagonal_step_row A i j c v"
unfolding diagonal_step_def unfolding diagonal_step_row_def[abs_def]
by auto
text‹Code equation to avoid recalculations when computing the Bezout coefficients. ›
lemma euclid_ext2_code[code]:
"euclid_ext2 a b = (let ((p,q),d) = euclid_ext a b in (p,q, - b div d, a div d, d))"
unfolding euclid_ext2_def split_beta Let_def
by auto
subsection‹Examples of execution›
value "let A= list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3
in matrix_to_list_of_list (diagonal_to_Smith A euclid_ext2)"
text‹Example obtained from:
\url{https://math.stackexchange.com/questions/77063/how-do-i-get-this-matrix-in-smith-normal-form-and-is-smith-normal-form-unique}
›
value "let A= list_of_list_to_matrix
[
[[:-3,1:],0,0,0],
[0,[:1,1:],0,0],
[0,0,[:1,1:],0],
[0,0,0,[:1,1:]]]::rat poly^4^4
in matrix_to_list_of_list (diagonal_to_Smith A euclid_ext2)"
text‹Polynomial matrix›
value "let A = list_of_list_to_matrix
[
[[:-3,1:],0,0,0],
[0,[:1,1:],0,0],
[0,0,[:1,1:],0],
[0,0,0,[:1,1:]],
[0,0,0,0]]::rat poly^4^5
in matrix_to_list_of_list (diagonal_to_Smith A euclid_ext2)"
subsection‹Soundness of the algorithm›
lemma nrows_diagonal_step[simp]: "nrows (diagonal_step A i j c v) = nrows A"
by (simp add: nrows_def)
lemma ncols_diagonal_step[simp]: "ncols (diagonal_step A i j c v) = ncols A"
by (simp add: ncols_def)
context
fixes bezout::"'a::{bezout_ring} ⇒ 'a ⇒ 'a × 'a × 'a × 'a × 'a"
assumes ib: "is_bezout_ext bezout"
begin
lemma split_beta_bezout: "bezout a b =
(fst(bezout a b),
fst (snd (bezout a b)),
fst (snd(snd (bezout a b))),
fst (snd(snd(snd (bezout a b)))),
snd (snd(snd(snd (bezout a b)))))" unfolding split_beta by (auto simp add: split_beta)
text‹The following lemma shows that @{text "diagonal_to_Smith_i"} preserves the previous element.
We use the assumption @{text "to_nat a = to_nat b"} in order to ensure that we are treating with
a diagonal entry. Since the matrix could be rectangular, the types of a and b can be different,
and thus we cannot write either @{text "a = b"} or @{text "A $ a $ b"}.›
lemma diagonal_to_Smith_i_preserves_previous_diagonal:
fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
assumes i_min: "i < min (nrows A) (ncols A)"
and "to_nat a ∉ set xs" and "to_nat a = to_nat b"
and "to_nat a ≠ i"
and elements_xs_range: "∀x. x ∈ set xs ⟶ x<min (nrows A) (ncols A)"
shows "(diagonal_to_Smith_i xs A i bezout) $ a $ b = A $ a $ b"
using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
case (1 A i bezout)
then show ?case by auto
next
case (2 j xs A i bezout)
let ?Aii = "A $ from_nat i $ from_nat i"
let ?Ajj = "A $ from_nat j $ from_nat j"
let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ p"
let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ q"
let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ u"
let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
let ?A'="diagonal_step A i j ?d ?v"
have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
by (simp add: split_beta)
show ?case
proof (cases "?Aii dvd ?Ajj")
case True
then show ?thesis
using "2.hyps" "2.prems" by auto
next
case False
note i_min = 2(3)
note hyp = 2(2)
note i_notin = 2(4)
note a_eq_b = "2.prems"(3)
note elements_xs = 2(7)
note a_not_i = 2(6)
have a_not_j: "a ≠ from_nat j"
by (metis elements_xs i_notin list.set_intros(1) min_less_iff_conj nrows_def to_nat_from_nat_id)
have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout"
using False by (auto simp add: split_beta)
also have "... $ a $ b = ?A' $ a $ b"
by (rule hyp[OF False], insert i_notin i_min a_eq_b a_not_i pquvd elements_xs, auto)
also have "... = A $ a $ b"
unfolding diagonal_step_def
using a_not_j a_not_i
by (smt i_min min.strict_boundedE nrows_def to_nat_from_nat_id vec_lambda_beta)
finally show ?thesis .
qed
qed
lemma diagonal_step_dvd1[simp]:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" and j i
defines "v==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
and "d==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
shows "diagonal_step A i j d v $ from_nat i $ from_nat i dvd A $ from_nat i $ from_nat i"
using ib unfolding is_bezout_ext_def diagonal_step_def v_def d_def
by (auto simp add: split_beta)
lemma diagonal_step_dvd2[simp]:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" and j i
defines "v==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
and "d==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
shows "diagonal_step A i j d v $ from_nat i $ from_nat i dvd A $ from_nat j $ from_nat j"
using ib unfolding is_bezout_ext_def diagonal_step_def v_def d_def
by (auto simp add: split_beta)
end
text‹Once the step is carried out, the new element ${A'}_{ii}$ will divide the element $A_{ii}$›
lemma diagonal_to_Smith_i_dvd_ii:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
assumes ib: "is_bezout_ext bezout"
shows "diagonal_to_Smith_i xs A i bezout $ from_nat i $ from_nat i dvd A $ from_nat i $ from_nat i"
using ib
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
case (1 A i bezout)
then show ?case by auto
next
case (2 j xs A i bezout)
let ?Aii = "A $ from_nat i $ from_nat i"
let ?Ajj = "A $ from_nat j $ from_nat j"
let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ p"
let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ q"
let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ u"
let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
let ?A'="diagonal_step A i j ?d ?v"
have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
by (simp add: split_beta)
note ib = "2.prems"(1)
show ?case
proof (cases "?Aii dvd ?Ajj")
case True
then show ?thesis
using "2.hyps"(1) "2.prems" by auto
next
case False
note hyp = "2.hyps"(2)
have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout"
using False by (auto simp add: split_beta)
also have "... $ from_nat i $ from_nat i dvd ?A' $ from_nat i $ from_nat i"
by (rule hyp[OF False], insert pquvd ib, auto)
also have "... dvd A $ from_nat i $ from_nat i"
unfolding diagonal_step_def using ib unfolding is_bezout_ext_def
by (auto simp add: split_beta)
finally show ?thesis .
qed
qed
text‹Once the step is carried out, the new element ${A'}_{ii}$
divides the rest of elements of the diagonal. This proof requires commutativity (already
included in the type restriction @{text "bezout_ring"}).›
lemma diagonal_to_Smith_i_dvd_jj:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
assumes ib: "is_bezout_ext bezout"
and i_min: "i < min (nrows A) (ncols A)"
and elements_xs_range: "∀x. x ∈ set xs ⟶ x<min (nrows A) (ncols A)"
and "to_nat a ∈ set xs"
and "to_nat a = to_nat b"
and "to_nat a ≠ i"
and "distinct xs"
shows "(diagonal_to_Smith_i xs A i bezout) $ (from_nat i) $ (from_nat i)
dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b"
using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
case (1 A i)
then show ?case by auto
next
case (2 j xs A i bezout)
let ?Aii = "A $ from_nat i $ from_nat i"
let ?Ajj = "A $ from_nat j $ from_nat j"
let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ p"
let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ q"
let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ u"
let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
let ?A'="diagonal_step A i j ?d ?v"
have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
by (simp add: split_beta)
note ib = "2.prems"(1)
note to_nat_a_not_i = 2(8)
note i_min = 2(4)
note elements_xs = "2.prems"(3)
note a_eq_b = "2.prems"(5)
note a_in_j_xs = 2(6)
note distinct = 2(9)
show ?case
proof (cases "?Aii dvd ?Ajj")
case True note Aii_dvd_Ajj = True
show ?thesis
proof (cases "to_nat a = j")
case True
have a: "a = (from_nat j::'c)" using True by auto
have b: "b = (from_nat j::'b)"
using True a_eq_b by auto
have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs A i bezout"
using Aii_dvd_Ajj by auto
also have "... $ from_nat j $ from_nat j = A $ from_nat j $ from_nat j"
proof (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib i_min])
show "to_nat (from_nat j::'c) ∉ set xs" using True a_in_j_xs distinct by auto
show "to_nat (from_nat j::'c) = to_nat (from_nat j::'b)"
by (metis True a_eq_b from_nat_to_nat_id)
show "to_nat (from_nat j::'c) ≠ i"
using True to_nat_a_not_i by auto
show "∀x. x ∈ set xs ⟶ x < min (nrows A) (ncols A)" using elements_xs by auto
qed
finally have "diagonal_to_Smith_i (j # xs) A i bezout $ from_nat j $ from_nat j
= A $ from_nat j $ from_nat j " .
hence "diagonal_to_Smith_i (j # xs) A i bezout $ a $ b = ?Ajj" unfolding a b .
moreover have "diagonal_to_Smith_i (j # xs) A i bezout $ from_nat i $ from_nat i dvd ?Aii"
by (rule diagonal_to_Smith_i_dvd_ii[OF ib])
ultimately show ?thesis using Aii_dvd_Ajj dvd_trans by auto
next
case False
have a_in_xs: "to_nat a ∈ set xs" using False using "2.prems"(4) by auto
have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs A i bezout"
using True by auto
also have "... $ (from_nat i) $ (from_nat i) dvd diagonal_to_Smith_i xs A i bezout $ a $ b"
by (rule "2.hyps"(1)[OF True ib i_min _ a_in_xs a_eq_b to_nat_a_not_i])
(insert elements_xs distinct, auto)
finally show ?thesis .
qed
next
case False note Aii_not_dvd_Ajj = False
show ?thesis
proof (cases "to_nat a ∈ set xs")
case True note a_in_xs = True
have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout"
using False by (auto simp add: split_beta)
also have "... $ from_nat i $ from_nat i dvd diagonal_to_Smith_i xs ?A' i bezout $ a $ b"
by (rule "2.hyps"(2)[OF False _ _ _ _ _ _ _ _ _ a_in_xs a_eq_b to_nat_a_not_i ])
(insert elements_xs distinct i_min ib pquvd, auto simp add: nrows_def ncols_def)
finally show ?thesis .
next
case False
have to_nat_a_eq_j: "to_nat a = j"
using False a_in_j_xs by auto
have a: "a = (from_nat j::'c)" using to_nat_a_eq_j by auto
have b: "b = (from_nat j::'b)" using to_nat_a_eq_j a_eq_b by auto
have d_eq: "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout"
using Aii_not_dvd_Ajj by (simp add: split_beta)
also have "... $ a $ b = ?A' $ a $ b"
by (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib _ False a_eq_b to_nat_a_not_i])
(insert i_min elements_xs ib, auto)
finally have "diagonal_to_Smith_i (j # xs) A i bezout $ a $ b = ?A' $ a $ b" .
moreover have "diagonal_to_Smith_i (j # xs) A i bezout $ from_nat i $ from_nat i
dvd ?A' $ from_nat i $ from_nat i"
using d_eq diagonal_to_Smith_i_dvd_ii[OF ib] by simp
moreover have "?A' $ from_nat i $ from_nat i dvd ?A' $ from_nat j $ from_nat j"
unfolding diagonal_step_def using ib unfolding is_bezout_ext_def split_beta
by (auto, meson dvd_mult)+
ultimately show ?thesis using dvd_trans a b by auto
qed
qed
qed
text‹The step preserves everything that is not in the diagonal›
lemma diagonal_to_Smith_i_preserves_previous:
fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
assumes ib: "is_bezout_ext bezout"
and i_min: "i < min (nrows A) (ncols A)"
and a_not_b: "to_nat a ≠ to_nat b"
and elements_xs_range: "∀x. x ∈ set xs ⟶ x<min (nrows A) (ncols A)"
shows "(diagonal_to_Smith_i xs A i bezout) $ a $ b = A $ a $ b"
using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
case (1 A i)
then show ?case by auto
next
case (2 j xs A i bezout)
let ?Aii = "A $ from_nat i $ from_nat i"
let ?Ajj = "A $ from_nat j $ from_nat j"
let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ p"
let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ q"
let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ u"
let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
let ?A'="diagonal_step A i j ?d ?v"
have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
by (simp add: split_beta)
note ib = "2.prems"(1)
show ?case
proof (cases "?Aii dvd ?Ajj")
case True
then show ?thesis
using "2.hyps"(1) "2.prems" by auto
next
case False
note hyp = "2.hyps"(2)
have a1: "a = from_nat i ⟶ b ≠ from_nat i"
by (metis "2.prems" a_not_b from_nat_not_eq min.strict_boundedE ncols_def nrows_def)
have a2: "a = from_nat j ⟶ b ≠ from_nat j"
by (metis "2.prems" a_not_b list.set_intros(1) min_less_iff_conj
ncols_def nrows_def to_nat_from_nat_id)
have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout"
using False by (simp add: split_beta)
also have "... $ a $ b = ?A' $ a $ b"
by (rule hyp[OF False], insert "2.prems" ib pquvd, auto)
also have "... = A $ a $ b" unfolding diagonal_step_def using a1 a2 by auto
finally show ?thesis .
qed
qed
lemma diagonal_step_preserves:
fixes A::"'a::{times}^'b::mod_type^'c::mod_type"
assumes ai: "a ≠ i" and aj: "a ≠ j" and a_min: "a < min (nrows A) (ncols A)"
and i_min: "i < min (nrows A) (ncols A)"
and j_min: "j < min (nrows A) (ncols A)"
shows "diagonal_step A i j d v $ from_nat a $ from_nat b = A $ from_nat a $ from_nat b"
proof -
have 1: "(from_nat a::'c) ≠ from_nat i"
by (metis a_min ai from_nat_eq_imp_eq i_min min.strict_boundedE nrows_def)
have 2: "(from_nat a::'c) ≠ from_nat j"
by (metis a_min aj from_nat_eq_imp_eq j_min min.strict_boundedE nrows_def)
show ?thesis
using 1 2 unfolding diagonal_step_def by auto
qed
context GCD_ring
begin
lemma gcd_greatest:
assumes "is_gcd gcd'" and "c dvd a" and "c dvd b"
shows "c dvd gcd' a b"
using assms is_gcd_def by blast
end
text‹This is a key lemma for the soundness of the algorithm.›
lemma diagonal_to_Smith_i_dvd:
fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
assumes ib: "is_bezout_ext bezout"
and i_min: "i < min (nrows A) (ncols A)"
and elements_xs_range: "∀x. x ∈ set xs ⟶ x<min (nrows A) (ncols A)"
and "∀a b. to_nat a∈insert i (set xs) ∧ to_nat a = to_nat b ⟶
A $ (from_nat c) $ (from_nat c) dvd A $ a $ b"
and "c ∉ (set xs)" and c: "c<min (nrows A) (ncols A)"
and "distinct xs"
shows "A $ (from_nat c) $ (from_nat c) dvd
(diagonal_to_Smith_i xs A i bezout) $ (from_nat i) $ (from_nat i)"
using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
case (1 A i)
then show ?case
by (auto simp add: ncols_def nrows_def to_nat_from_nat_id)
next
case (2 j xs A i bezout)
let ?Aii = "A $ from_nat i $ from_nat i"
let ?Ajj = "A $ from_nat j $ from_nat j"
let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ p"
let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ q"
let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ u"
let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
let ?A'="diagonal_step A i j ?d ?v"
have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
by (simp add: split_beta)
note ib = "2.prems"(1)
show ?case
proof (cases "?Aii dvd ?Ajj")
case True note Aii_dvd_Ajj = True
show ?thesis using True
using "2.hyps" "2.prems" by force
next
case False
let ?Acc = "A $ from_nat c $ from_nat c"
let ?D="diagonal_step A i j ?d ?v"
note hyp = "2.hyps"(2)
note dvd_condition = "2.prems"(4)
note a_eq_b = "2.hyps"
have 1: "(from_nat c::'c) ≠ from_nat i"
by (metis "2.prems" False c insert_iff list.set_intros(1)
min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id)
have 2: "(from_nat c::'c) ≠ from_nat j"
by (metis "2.prems" c insertI1 list.simps(15) min_less_iff_conj nrows_def
to_nat_from_nat_id)
have "?D $ from_nat c $ from_nat c = ?Acc"
unfolding diagonal_step_def using 1 2 by auto
have aux: "?D $ from_nat c $ from_nat c dvd ?D $ a $ b"
if a_in_set: "to_nat a ∈ insert i (set xs)" and ab: "to_nat a = to_nat b" for a b
proof -
have Acc_dvd_Aii: "?Acc dvd ?Aii"
by (metis "2.prems"(2) "2.prems"(4) insert_iff min.strict_boundedE
ncols_def nrows_def to_nat_from_nat_id)
moreover have Acc_dvd_Ajj: "?Acc dvd ?Ajj"
by (metis "2.prems"(3) "2.prems"(4) insert_iff list.set_intros(1)
min_less_iff_conj ncols_def nrows_def to_nat_from_nat_id)
ultimately have Acc_dvd_gcd: "?Acc dvd ?d"
by (metis (mono_tags, lifting) ib is_gcd_def is_gcd_is_bezout_ext)
show ?thesis
using 1 2 Acc_dvd_Ajj Acc_dvd_Aii Acc_dvd_gcd a_in_set ab dvd_condition
unfolding diagonal_step_def by auto
qed
have "?A' $ from_nat c $ from_nat c = A $ from_nat c $ from_nat c"
unfolding diagonal_step_def using 1 2 by auto
moreover have "?A' $ from_nat c $ from_nat c
dvd diagonal_to_Smith_i xs ?A' i bezout $ from_nat i $ from_nat i"
by (rule hyp[OF False _ _ _ _ _ _ ib])
(insert nrows_def ncols_def "2.prems" "2.hyps" aux pquvd, auto)
ultimately show ?thesis using False by (auto simp add: split_beta)
qed
qed
lemma diagonal_to_Smith_i_dvd2:
fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
assumes ib: "is_bezout_ext bezout"
and i_min: "i < min (nrows A) (ncols A)"
and elements_xs_range: "∀x. x ∈ set xs ⟶ x<min (nrows A) (ncols A)"
and dvd_condition: "∀a b. to_nat a ∈ insert i (set xs) ∧ to_nat a = to_nat b ⟶
A $ (from_nat c) $ (from_nat c) dvd A $ a $ b"
and c_notin: "c ∉ (set xs)"
and c: "c < min (nrows A) (ncols A)"
and distinct: "distinct xs"
and ab: "to_nat a = to_nat b"
and a_in: "to_nat a ∈ insert i (set xs)"
shows "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b"
proof (cases "a = from_nat i")
case True
hence b: "b = from_nat i"
by (metis ab from_nat_to_nat_id i_min min_less_iff_conj nrows_def to_nat_from_nat_id)
show ?thesis by (unfold True b, rule diagonal_to_Smith_i_dvd, insert assms, auto)
next
case False
have ai: "to_nat a ≠ i" using False by auto
hence bi: "to_nat b ≠ i" by (simp add: ab)
have "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ from_nat i $ from_nat i"
by (rule diagonal_to_Smith_i_dvd, insert assms, auto)
also have "... dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b"
by (rule diagonal_to_Smith_i_dvd_jj, insert assms False ai bi, auto)
finally show ?thesis .
qed
lemma diagonal_to_Smith_i_dvd2_k:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
assumes ib: "is_bezout_ext bezout"
and i_min: "i < min (nrows A) (ncols A)"
and elements_xs_range: "∀x. x ∈ set xs ⟶ x<k" and "k≤min (nrows A) (ncols A)"
and dvd_condition: "∀a b. to_nat a ∈ insert i (set xs) ∧ to_nat a = to_nat b ⟶
A $ (from_nat c) $ (from_nat c) dvd A $ a $ b"
and c_notin: "c ∉ (set xs)"
and c: "c < min (nrows A) (ncols A)"
and distinct: "distinct xs"
and ab: "to_nat a = to_nat b"
and a_in: "to_nat a ∈ insert i (set xs)"
shows "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b"
proof (cases "a = from_nat i")
case True
hence b: "b = from_nat i"
by (metis ab from_nat_to_nat_id i_min min_less_iff_conj nrows_def to_nat_from_nat_id)
show ?thesis by (unfold True b, rule diagonal_to_Smith_i_dvd, insert assms, auto)
next
case False
have ai: "to_nat a ≠ i" using False by auto
hence bi: "to_nat b ≠ i" by (simp add: ab)
have "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ from_nat i $ from_nat i"
by (rule diagonal_to_Smith_i_dvd, insert assms, auto)
also have "... dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b"
by (rule diagonal_to_Smith_i_dvd_jj, insert assms False ai bi, auto)
finally show ?thesis .
qed
lemma diagonal_to_Smith_row_i_preserves_previous:
fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
assumes ib: "is_bezout_ext bezout"
and i_min: "i < min (nrows A) (ncols A)"
and a_not_b: "to_nat a ≠ to_nat b"
shows "Diagonal_to_Smith_row_i A i bezout $ a $ b = A $ a $ b"
unfolding Diagonal_to_Smith_row_i_def
by (rule diagonal_to_Smith_i_preserves_previous, insert assms, auto)
lemma diagonal_to_Smith_row_i_preserves_previous_diagonal:
fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
assumes ib: "is_bezout_ext bezout"
and i_min: "i < min (nrows A) (ncols A)"
and a_notin: "to_nat a ∉ set [i + 1..<min (nrows A) (ncols A)]"
and ab: "to_nat a = to_nat b"
and ai: "to_nat a ≠ i"
shows "Diagonal_to_Smith_row_i A i bezout $ a $ b = A $ a $ b"
unfolding Diagonal_to_Smith_row_i_def
by (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib i_min a_notin ab ai], auto)
context
fixes bezout::"'a::{bezout_ring} ⇒ 'a ⇒ 'a × 'a × 'a × 'a × 'a"
assumes ib: "is_bezout_ext bezout"
begin
lemma diagonal_to_Smith_row_i_dvd_jj:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
assumes "to_nat a ∈ {i..<min (nrows A) (ncols A)}"
and "to_nat a = to_nat b"
shows "(Diagonal_to_Smith_row_i A i bezout) $ (from_nat i) $ (from_nat i)
dvd (Diagonal_to_Smith_row_i A i bezout) $ a $ b"
proof (cases "to_nat a = i")
case True
then show ?thesis
by (metis assms(2) dvd_refl from_nat_to_nat_id)
next
case False
show ?thesis
unfolding Diagonal_to_Smith_row_i_def
by (rule diagonal_to_Smith_i_dvd_jj, insert assms False ib, auto)
qed
lemma diagonal_to_Smith_row_i_dvd_ii:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
shows "Diagonal_to_Smith_row_i A i bezout $ from_nat i $ from_nat i dvd A $ from_nat i $ from_nat i"
unfolding Diagonal_to_Smith_row_i_def
by (rule diagonal_to_Smith_i_dvd_ii[OF ib])
lemma diagonal_to_Smith_row_i_dvd_jj':
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
assumes a_in: "to_nat a ∈ {i..<min (nrows A) (ncols A)}"
and ab: "to_nat a = to_nat b"
and ci: "c≤i"
and dvd_condition: "∀a b. to_nat a ∈ (set [i..<min (nrows A) (ncols A)]) ∧ to_nat a = to_nat b
⟶ A $ from_nat c $ from_nat c dvd A $ a $ b"
shows "(Diagonal_to_Smith_row_i A i bezout) $ (from_nat c) $ (from_nat c)
dvd (Diagonal_to_Smith_row_i A i bezout) $ a $ b"
proof (cases "c = i")
case True
then show ?thesis using assms True diagonal_to_Smith_row_i_dvd_jj
by metis
next
case False
hence ci2: "c<i" using ci by auto
have 1: "to_nat (from_nat c::'c) ∉ (set [i+1..<min (nrows A) (ncols A)])"
by (metis Suc_eq_plus1 ci atLeastLessThan_iff from_nat_mono
le_imp_less_Suc less_irrefl less_le_trans set_upt to_nat_le to_nat_less_card)
have 2: "to_nat (from_nat c) ≠ i"
using ci2 from_nat_mono to_nat_less_card by fastforce
have 3: "to_nat (from_nat c::'c) = to_nat (from_nat c::'b)"
by (metis a_in ab atLeastLessThan_iff ci dual_order.strict_trans2 to_nat_from_nat_id to_nat_less_card)
have "(Diagonal_to_Smith_row_i A i bezout) $ (from_nat c) $ (from_nat c)
= A $(from_nat c) $ (from_nat c)"
unfolding Diagonal_to_Smith_row_i_def
by (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib _ 1 3 2], insert assms, auto)
also have "... dvd (Diagonal_to_Smith_row_i A i bezout) $ a $ b"
unfolding Diagonal_to_Smith_row_i_def
by (rule diagonal_to_Smith_i_dvd2, insert assms False ci ib, auto)
finally show ?thesis .
qed
end
lemma diagonal_to_Smith_aux_append:
"diagonal_to_Smith_aux A (xs @ ys) bezout
= diagonal_to_Smith_aux (diagonal_to_Smith_aux A xs bezout) ys bezout"
by (induct A xs bezout rule: diagonal_to_Smith_aux.induct, auto)
lemma diagonal_to_Smith_aux_append2[simp]:
"diagonal_to_Smith_aux A (xs @ [ys]) bezout
= Diagonal_to_Smith_row_i (diagonal_to_Smith_aux A xs bezout) ys bezout"
by (induct A xs bezout rule: diagonal_to_Smith_aux.induct, auto)
lemma isDiagonal_eq_upt_k_min:
"isDiagonal A = isDiagonal_upt_k A (min (nrows A) (ncols A))"
unfolding isDiagonal_def isDiagonal_upt_k_def nrows_def ncols_def
by (auto, meson less_trans not_less_iff_gr_or_eq to_nat_less_card)
lemma isDiagonal_eq_upt_k_max:
"isDiagonal A = isDiagonal_upt_k A (max (nrows A) (ncols A))"
unfolding isDiagonal_def isDiagonal_upt_k_def nrows_def ncols_def
by (auto simp add: less_max_iff_disj to_nat_less_card)
lemma isDiagonal:
assumes "isDiagonal A"
and "to_nat a ≠ to_nat b" shows "A $ a $ b = 0"
using assms unfolding isDiagonal_def by auto
lemma nrows_diagonal_to_Smith_aux[simp]:
shows "nrows (diagonal_to_Smith_aux A xs bezout) = nrows A" unfolding nrows_def by auto
lemma ncols_diagonal_to_Smith_aux[simp]:
shows "ncols (diagonal_to_Smith_aux A xs bezout) = ncols A" unfolding ncols_def by auto
context
fixes bezout::"'a::{bezout_ring} ⇒ 'a ⇒ 'a × 'a × 'a × 'a × 'a"
assumes ib: "is_bezout_ext bezout"
begin
lemma isDiagonal_diagonal_to_Smith_aux:
assumes diag_A: "isDiagonal A" and k: "k < min (nrows A) (ncols A)"
shows "isDiagonal (diagonal_to_Smith_aux A [0..<k] bezout)"
using k
proof (induct k)
case 0
then show ?case using diag_A by auto
next
case (Suc k)
have "Diagonal_to_Smith_row_i (diagonal_to_Smith_aux A [0..<k] bezout) k bezout $ a $ b = 0"
if a_not_b: "to_nat a ≠ to_nat b" for a b
proof -
have "Diagonal_to_Smith_row_i (diagonal_to_Smith_aux A [0..<k] bezout) k bezout $ a $ b
= (diagonal_to_Smith_aux A [0..<k] bezout) $ a $ b"
by (rule diagonal_to_Smith_row_i_preserves_previous[OF ib _ a_not_b], insert Suc.prems, auto)
also have "... = 0"
by (rule isDiagonal[OF Suc.hyps a_not_b], insert Suc.prems, auto)
finally show ?thesis .
qed
thus ?case unfolding isDiagonal_def by auto
qed
end
lemma to_nat_less_nrows[simp]:
fixes A::"'a^'b::mod_type^'c::mod_type"
and a::'c
shows "to_nat a < nrows A"
by (simp add: nrows_def to_nat_less_card)
lemma to_nat_less_ncols[simp]:
fixes A::"'a^'b::mod_type^'c::mod_type"
and a::'b
shows "to_nat a < ncols A"
by (simp add: ncols_def to_nat_less_card)
context
fixes bezout::"'a::{bezout_ring} ⇒ 'a ⇒ 'a × 'a × 'a × 'a × 'a"
assumes ib: "is_bezout_ext bezout"
begin
text‹The variables a and b must be arbitrary in the induction›
lemma diagonal_to_Smith_aux_dvd:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
assumes ab: "to_nat a = to_nat b"
and c: "c < k" and ca: "c ≤ to_nat a" and k: "k<min (nrows A) (ncols A)"
shows "diagonal_to_Smith_aux A [0..<k] bezout $ from_nat c $ from_nat c
dvd diagonal_to_Smith_aux A [0..<k] bezout $ a $ b"
using c ab ca k
proof (induct k arbitrary: a b)
case 0
then show ?case by auto
next
case (Suc k)
note c = Suc.prems(1)
note ab = Suc.prems(2)
note ca = Suc.prems(3)
note k = Suc.prems(4)
have k_min: "k < min (nrows A) (ncols A)" using k by auto
have a_less_ncols: "to_nat a < ncols A" using ab by auto
show ?case
proof (cases "c=k")
case True
hence k: "k≤to_nat a" using ca by auto
show ?thesis unfolding True
by (auto, rule diagonal_to_Smith_row_i_dvd_jj[OF ib _ ab], insert k a_less_ncols, auto)
next
case False note c_not_k = False
let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
have ck: "c<k" using Suc.prems False by auto
have hyp: "?Dk $ from_nat c $ from_nat c dvd ?Dk $ a $ b"
by (rule Suc.hyps[OF ck ab ca k_min])
have Dkk_Daa_bb: "?Dk $ from_nat c $ from_nat c dvd ?Dk $ aa $ bb"
if "to_nat aa ∈ set [k..<min (nrows ?Dk) (ncols ?Dk)]" and "to_nat aa = to_nat bb"
for aa bb using Suc.hyps ck k_min that(1) that(2) by auto
show ?thesis
proof (cases "k≤to_nat a")
case True
show ?thesis
by (auto, rule diagonal_to_Smith_row_i_dvd_jj'[OF ib _ ab])
(insert True a_less_ncols ck Dkk_Daa_bb, force+)
next
case False
have "diagonal_to_Smith_aux A [0..<Suc k] bezout $ from_nat c $ from_nat c
= Diagonal_to_Smith_row_i ?Dk k bezout $ from_nat c $ from_nat c" by auto
also have "... = ?Dk $ from_nat c $ from_nat c"
proof (rule diagonal_to_Smith_row_i_preserves_previous_diagonal[OF ib])
show "k < min (nrows ?Dk) (ncols ?Dk)" using k by auto
show "to_nat (from_nat c::'c) = to_nat (from_nat c::'b)"
by (metis assms(2) assms(4) less_trans min_less_iff_conj
ncols_def nrows_def to_nat_from_nat_id)
show "to_nat (from_nat c::'c) ≠ k"
using False ca from_nat_mono' to_nat_less_card to_nat_mono' by fastforce
show "to_nat (from_nat c::'c) ∉ set [k + 1..<min (nrows ?Dk) (ncols ?Dk)]"
by (metis Suc_eq_plus1 atLeastLessThan_iff c ca from_nat_not_eq
le_less_trans not_le set_upt to_nat_less_card)
qed
also have "... dvd ?Dk $ a $ b" using hyp .
also have "... = Diagonal_to_Smith_row_i ?Dk k bezout $ a $ b"
by (rule diagonal_to_Smith_row_i_preserves_previous_diagonal[symmetric, OF ib _ _ ab])
(insert False k, auto)
also have "... = diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b" by auto
finally show ?thesis .
qed
qed
qed
lemma Smith_normal_form_upt_k_Suc_imp_k:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
assumes s: "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<Suc k] bezout) k"
and k: "k<min (nrows A) (ncols A)"
shows "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"
proof (rule Smith_normal_form_upt_k_intro)
let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
fix a::'c and b::'b assume "to_nat a = to_nat b ∧ to_nat a + 1 < k ∧ to_nat b + 1 < k"
hence ab: "to_nat a = to_nat b" and ak: "to_nat a + 1 < k" and bk: "to_nat b + 1 < k" by auto
have a_not_k: "to_nat a ≠ k" using ak by auto
have a1_less_k1: "to_nat a + 1 < k + 1" using ak by linarith
have "?Dk $a $ b = diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b"
by (auto, rule diagonal_to_Smith_row_i_preserves_previous_diagonal[symmetric, OF ib _ _ ab a_not_k])
(insert ak k, auto)
also have "... dvd diagonal_to_Smith_aux A [0..<Suc k] bezout $ (a + 1) $ (b + 1)"
using ab ak bk s unfolding Smith_normal_form_upt_k_def by auto
also have "... = ?Dk $ (a+1) $ (b+1)"
proof (auto, rule diagonal_to_Smith_row_i_preserves_previous_diagonal[OF ib])
show "to_nat (a + 1) ≠ k" using ak
by (metis add_less_same_cancel2 nat_neq_iff not_add_less2 to_nat_0
to_nat_plus_one_less_card' to_nat_suc)
show "to_nat (a + 1) = to_nat (b + 1)"
by (metis ab ak from_nat_suc from_nat_to_nat_id k less_asym' min_less_iff_conj
ncols_def nrows_def suc_not_zero to_nat_from_nat_id to_nat_plus_one_less_card')
show "to_nat (a + 1) ∉ set [k + 1..<min (nrows ?Dk) (ncols ?Dk)]"
by (metis a1_less_k1 add_to_nat_def atLeastLessThan_iff k less_asym' min.strict_boundedE
not_less nrows_def set_upt suc_not_zero to_nat_1 to_nat_from_nat_id to_nat_plus_one_less_card')
show "k < min (nrows ?Dk) (ncols ?Dk)" using k by auto
qed
finally show "?Dk $ a $ b dvd ?Dk $ (a+1) $ (b+1)" .
next
let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
fix a::'c and b::'b
assume "to_nat a ≠ to_nat b ∧ (to_nat a < k ∨ to_nat b < k)"
hence ab: "to_nat a ≠ to_nat b" and ak_bk: "(to_nat a < k ∨ to_nat b < k)" by auto
have "?Dk $a $ b = diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b"
by (auto, rule diagonal_to_Smith_row_i_preserves_previous[symmetric, OF ib _ ab], insert k, auto)
also have "... = 0"
using ab ak_bk s unfolding Smith_normal_form_upt_k_def isDiagonal_upt_k_def
by auto
finally show "?Dk $ a $ b = 0" .
qed
lemma Smith_normal_form_upt_k_le:
assumes "a≤k" and "Smith_normal_form_upt_k A k"
shows "Smith_normal_form_upt_k A a" using assms
by (smt Smith_normal_form_upt_k_def isDiagonal_upt_k_def less_le_trans)
lemma Smith_normal_form_upt_k_imp_Suc_k:
assumes s: "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"
and k: "k<min (nrows A) (ncols A)"
shows "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<Suc k] bezout) k"
proof (rule Smith_normal_form_upt_k_intro)
let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
fix a::'c and b::'b assume "to_nat a = to_nat b ∧ to_nat a + 1 < k ∧ to_nat b + 1 < k"
hence ab: "to_nat a = to_nat b" and ak: "to_nat a + 1 < k" and bk: "to_nat b + 1 < k" by auto
have a_not_k: "to_nat a ≠ k" using ak by auto
have a1_less_k1: "to_nat a + 1 < k + 1" using ak by linarith
have "diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b = ?Dk $a $ b"
by (auto, rule diagonal_to_Smith_row_i_preserves_previous_diagonal[OF ib _ _ ab a_not_k])
(insert ak k, auto)
also have "... dvd ?Dk $ (a+1) $ (b+1)"
using s ak k ab unfolding Smith_normal_form_upt_k_def by auto
also have "... = diagonal_to_Smith_aux A [0..<Suc k] bezout $ (a + 1) $ (b + 1)"
proof (auto, rule diagonal_to_Smith_row_i_preserves_previous_diagonal[symmetric, OF ib])
show "to_nat (a + 1) ≠ k" using ak
by (metis add_less_same_cancel2 nat_neq_iff not_add_less2 to_nat_0
to_nat_plus_one_less_card' to_nat_suc)
show "to_nat (a + 1) = to_nat (b + 1)"
by (metis ab ak from_nat_suc from_nat_to_nat_id k less_asym' min_less_iff_conj
ncols_def nrows_def suc_not_zero to_nat_from_nat_id to_nat_plus_one_less_card')
show "to_nat (a + 1) ∉ set [k + 1..<min (nrows ?Dk) (ncols ?Dk)]"
by (metis a1_less_k1 add_to_nat_def to_nat_plus_one_less_card' less_asym' min.strict_boundedE
not_less nrows_def set_upt suc_not_zero to_nat_1 to_nat_from_nat_id atLeastLessThan_iff k)
show "k < min (nrows ?Dk) (ncols ?Dk)" using k by auto
qed
finally show "diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b
dvd diagonal_to_Smith_aux A [0..<Suc k] bezout $ (a + 1) $ (b + 1)" .
next
let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
fix a::'c and b::'b
assume "to_nat a ≠ to_nat b ∧ (to_nat a < k ∨ to_nat b < k)"
hence ab: "to_nat a ≠ to_nat b" and ak_bk: "(to_nat a < k ∨ to_nat b < k)" by auto
have "diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b = ?Dk $a $ b"
by (auto, rule diagonal_to_Smith_row_i_preserves_previous[OF ib _ ab], insert k, auto)
also have "... = 0"
using ab ak_bk s unfolding Smith_normal_form_upt_k_def isDiagonal_upt_k_def
by auto
finally show "diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b = 0" .
qed
corollary Smith_normal_form_upt_k_Suc_eq:
assumes k: "k<min (nrows A) (ncols A)"
shows "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<Suc k] bezout) k
= Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"
using Smith_normal_form_upt_k_Suc_imp_k Smith_normal_form_upt_k_imp_Suc_k k
by blast
end
lemma nrows_diagonal_to_Smith_i[simp]: "nrows (diagonal_to_Smith_i xs A i bezout) = nrows A"
by (induct xs A i bezout rule: diagonal_to_Smith_i.induct, auto simp add: nrows_def)
lemma ncols_diagonal_to_Smith_i[simp]: "ncols (diagonal_to_Smith_i xs A i bezout) = ncols A"
by (induct xs A i bezout rule: diagonal_to_Smith_i.induct, auto simp add: ncols_def)
lemma nrows_Diagonal_to_Smith_row_i[simp]: "nrows (Diagonal_to_Smith_row_i A i bezout) = nrows A"
unfolding Diagonal_to_Smith_row_i_def by auto
lemma ncols_Diagonal_to_Smith_row_i[simp]: "ncols (Diagonal_to_Smith_row_i A i bezout) = ncols A"
unfolding Diagonal_to_Smith_row_i_def by auto
lemma isDiagonal_diagonal_step:
assumes diag_A: "isDiagonal A" and i: "i<min (nrows A) (ncols A)"
and j: "j<min (nrows A) (ncols A)"
shows "isDiagonal (diagonal_step A i j d v)"
proof -
have i_eq: "to_nat (from_nat i::'b) = to_nat (from_nat i::'c)" using i
by (simp add: ncols_def nrows_def to_nat_from_nat_id)
moreover have j_eq: "to_nat (from_nat j::'b) = to_nat (from_nat j::'c)" using j
by (simp add: ncols_def nrows_def to_nat_from_nat_id)
ultimately show ?thesis
using assms
unfolding isDiagonal_def diagonal_step_def by auto
qed
lemma isDiagonal_diagonal_to_Smith_i:
assumes "isDiagonal A"
and elements_xs_range: "∀x. x ∈ set xs ⟶ x<min (nrows A) (ncols A)"
and "i<min (nrows A) (ncols A)"
shows "isDiagonal (diagonal_to_Smith_i xs A i bezout)"
using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
case (1 A i bezout)
then show ?case by auto
next
case (2 j xs A i bezout)
let ?Aii = "A $ from_nat i $ from_nat i"
let ?Ajj = "A $ from_nat j $ from_nat j"
let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ p"
let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ q"
let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ u"
let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
let ?A'="diagonal_step A i j ?d ?v"
have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
by (simp add: split_beta)
show ?case
proof (cases "?Aii dvd ?Ajj")
case True
thus ?thesis
using "2.hyps" "2.prems" by auto
next
case False
have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout"
using False by (simp add: split_beta)
also have "isDiagonal ..." thm "2.prems"
proof (rule "2.hyps"(2)[OF False])
show "isDiagonal
(diagonal_step A i j ?d ?v)" by (rule isDiagonal_diagonal_step, insert "2.prems", auto)
qed (insert pquvd "2.prems", auto)
finally show ?thesis .
qed
qed
lemma isDiagonal_Diagonal_to_Smith_row_i:
assumes "isDiagonal A" and "i < min (nrows A) (ncols A)"
shows "isDiagonal (Diagonal_to_Smith_row_i A i bezout)"
using assms isDiagonal_diagonal_to_Smith_i
unfolding Diagonal_to_Smith_row_i_def by force
lemma isDiagonal_diagonal_to_Smith_aux_general:
assumes elements_xs_range: "∀x. x ∈ set xs ⟶ x<min (nrows A) (ncols A)"
and "isDiagonal A"
shows "isDiagonal (diagonal_to_Smith_aux A xs bezout)"
using assms
proof (induct A xs bezout rule: diagonal_to_Smith_aux.induct)
case (1 A)
then show ?case by auto
next
case (2 A i xs bezout)
note k = "2.prems"(1)
note elements_xs_range = "2.prems"(2)
have "diagonal_to_Smith_aux A (i # xs) bezout
= diagonal_to_Smith_aux (Diagonal_to_Smith_row_i A i bezout) xs bezout"
by auto
also have "isDiagonal (...)"
by (rule "2.hyps", insert isDiagonal_Diagonal_to_Smith_row_i "2.prems" k, auto)
finally show ?case .
qed
context
fixes bezout::"'a::{bezout_ring} ⇒ 'a ⇒ 'a × 'a × 'a × 'a × 'a"
assumes ib: "is_bezout_ext bezout"
begin
text‹The algorithm is iterated up to position k (not included). Thus, the matrix
is in Smith normal form up to position k (not included).›
lemma Smith_normal_form_upt_k_diagonal_to_Smith_aux:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
assumes "k<min (nrows A) (ncols A)" and d: "isDiagonal A"
shows "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"
using assms
proof (induct k)
case 0
then show ?case by auto
next
case (Suc k)
note Suc_k = "Suc.prems"(1)
have hyp: "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"
by (rule Suc.hyps, insert Suc.prems, simp)
have k: "k < min (nrows A) (ncols A)" using Suc.prems by auto
let ?A = "diagonal_to_Smith_aux A [0..<k] bezout"
let ?D_Suck = "diagonal_to_Smith_aux A [0..<Suc k] bezout"
have set_rw: "[0..<Suc k] = [0..<k] @ [k]" by auto
show ?case
proof (rule Smith_normal_form_upt_k1_intro_diagonal)
show "Smith_normal_form_upt_k (?D_Suck) k"
by (rule Smith_normal_form_upt_k_imp_Suc_k[OF ib hyp k])
show "?D_Suck $ from_nat (k - 1) $ from_nat (k - 1) dvd ?D_Suck $ from_nat k $ from_nat k"
proof (rule diagonal_to_Smith_aux_dvd[OF ib _ _ _ Suc_k])
show "to_nat (from_nat k::'c) = to_nat (from_nat k::'b)"
by (metis k min_less_iff_conj ncols_def nrows_def to_nat_from_nat_id)
show "k - 1 ≤ to_nat (from_nat k::'c)"
by (metis diff_le_self k min_less_iff_conj nrows_def to_nat_from_nat_id)
qed auto
show "isDiagonal (diagonal_to_Smith_aux A [0..<Suc k] bezout)"
by (rule isDiagonal_diagonal_to_Smith_aux[OF ib d Suc_k])
qed
qed
end
lemma nrows_diagonal_to_Smith[simp]: "nrows (diagonal_to_Smith A bezout) = nrows A"
unfolding diagonal_to_Smith_def by auto
lemma ncols_diagonal_to_Smith[simp]: "ncols (diagonal_to_Smith A bezout) = ncols A"
unfolding diagonal_to_Smith_def by auto
lemma isDiagonal_diagonal_to_Smith:
assumes d: "isDiagonal A"
shows "isDiagonal (diagonal_to_Smith A bezout)"
unfolding diagonal_to_Smith_def
by (rule isDiagonal_diagonal_to_Smith_aux_general[OF _ d], auto)
text‹This is the soundess lemma.›
lemma Smith_normal_form_diagonal_to_Smith:
fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
assumes ib: "is_bezout_ext bezout"
and d: "isDiagonal A"
shows "Smith_normal_form (diagonal_to_Smith A bezout)"
proof -
let ?k = "min (nrows A) (ncols A) - 2"
let ?Dk = "(diagonal_to_Smith_aux A [0..<?k] bezout)"
have min_eq: "min (nrows A) (ncols A) - 1 = Suc ?k"
by (metis Suc_1 Suc_diff_Suc min_less_iff_conj ncols_def nrows_def to_nat_1 to_nat_less_card)
have set_rw: "[0..<min (nrows A) (ncols A) - 1] = [0..<?k] @ [?k]"
unfolding min_eq by auto
have d2: "isDiagonal (diagonal_to_Smith A bezout)"
by (rule isDiagonal_diagonal_to_Smith[OF d])
have smith_Suc_k: "Smith_normal_form_upt_k (diagonal_to_Smith A bezout) (Suc ?k)"
proof (rule Smith_normal_form_upt_k1_intro_diagonal[OF _ d2])
have "diagonal_to_Smith A bezout = diagonal_to_Smith_aux A [0..<min (nrows A) (ncols A) - 1] bezout"
unfolding diagonal_to_Smith_def by auto
also have "... = Diagonal_to_Smith_row_i ?Dk ?k bezout"
unfolding set_rw
unfolding diagonal_to_Smith_aux_append2 by auto
finally have d_rw: "diagonal_to_Smith A bezout = Diagonal_to_Smith_row_i ?Dk ?k bezout" .
have "Smith_normal_form_upt_k ?Dk ?k"
by (rule Smith_normal_form_upt_k_diagonal_to_Smith_aux[OF ib _ d], insert min_eq, linarith)
thus "Smith_normal_form_upt_k (diagonal_to_Smith A bezout) ?k" unfolding d_rw
by (metis Smith_normal_form_upt_k_Suc_eq Suc_1 ib d_rw diagonal_to_Smith_def diff_0_eq_0
diff_less min_eq not_gr_zero zero_less_Suc)
show "diagonal_to_Smith A bezout $ from_nat (?k - 1) $ from_nat (?k - 1) dvd
diagonal_to_Smith A bezout $ from_nat ?k $ from_nat ?k"
proof (unfold diagonal_to_Smith_def, rule diagonal_to_Smith_aux_dvd[OF ib])
show "?k - 1 < min (nrows A) (ncols A) - 1"
using min_eq by linarith
show "min (nrows A) (ncols A) - 1 < min (nrows A) (ncols A)" using min_eq by linarith
thus "to_nat (from_nat ?k::'c) = to_nat (from_nat ?k::'b)"
by (metis (mono_tags, lifting) Suc_lessD min_eq min_less_iff_conj
ncols_def nrows_def to_nat_from_nat_id)
show "?k - 1 ≤ to_nat (from_nat ?k::'c)"
by (metis (no_types, lifting) diff_le_self from_nat_not_eq lessI less_le_trans
min.cobounded1 min_eq nrows_def)
qed
qed
have s_eq: "Smith_normal_form (diagonal_to_Smith A bezout)
= Smith_normal_form_upt_k (diagonal_to_Smith A bezout)
(Suc (min (nrows (diagonal_to_Smith A bezout)) (ncols (diagonal_to_Smith A bezout)) - 1))"
unfolding Smith_normal_form_min by (simp add: ncols_def nrows_def)
let ?min1="(min (nrows (diagonal_to_Smith A bezout)) (ncols (diagonal_to_Smith A bezout)) - 1)"
show ?thesis unfolding s_eq
proof (rule Smith_normal_form_upt_k1_intro_diagonal[OF _ d2])
show "Smith_normal_form_upt_k (diagonal_to_Smith A bezout) ?min1"
using smith_Suc_k min_eq by auto
have "diagonal_to_Smith A bezout $ from_nat ?k $ from_nat ?k
dvd diagonal_to_Smith A bezout $ from_nat (?k + 1) $ from_nat (?k + 1)"
by (smt One_nat_def Suc_eq_plus1 ib Suc_pred diagonal_to_Smith_aux_dvd diagonal_to_Smith_def
le_add1 lessI min_eq min_less_iff_conj ncols_def nrows_def to_nat_from_nat_id zero_less_card_finite)
thus "diagonal_to_Smith A bezout $ from_nat (?min1 - 1) $ from_nat (?min1 - 1)
dvd diagonal_to_Smith A bezout $ from_nat ?min1 $ from_nat ?min1"
using min_eq by auto
qed
qed
subsection‹Implementation and formal proof
of the matrices $P$ and $Q$ which transform the input matrix by means of elementary operations.›
fun diagonal_step_PQ :: "'a::{bezout_ring}^'cols::mod_type^'rows::mod_type ⇒ nat ⇒ nat ⇒ 'a bezout ⇒
(
('a::{bezout_ring}^'rows::mod_type^'rows::mod_type) ×
('a::{bezout_ring}^'cols::mod_type^'cols::mod_type)
)"
where "diagonal_step_PQ A i k bezout =
(let i_row = from_nat i; k_row = from_nat k; i_col = from_nat i; k_col = from_nat k;
(p, q, u, v, d) = bezout (A $ i_row $ from_nat i) (A $ k_row $ from_nat k);
P = row_add (interchange_rows (row_add (mat 1) k_row i_row p) i_row k_row) k_row i_row (-v);
Q = mult_column (column_add (column_add (mat 1) i_col k_col q) k_col i_col u) k_col (-1)
in (P,Q)
)"
text‹Examples›
value "let A = list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3;
i=0; k=1;
(p, q, u, v, d) = euclid_ext2 (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k);
(P,Q) = diagonal_step_PQ A i k euclid_ext2
in matrix_to_list_of_list (diagonal_step A i k d v)"
value "let A = list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3;
i=0; k=1;
(p, q, u, v, d) = euclid_ext2 (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k);
(P,Q) = diagonal_step_PQ A i k euclid_ext2
in matrix_to_list_of_list (P**(A)**Q)"
value "let A = list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3;
i=0; k=1;
(p, q, u, v, d) = euclid_ext2 (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k);
(P,Q) = diagonal_step_PQ A i k euclid_ext2
in matrix_to_list_of_list (P**(A)**Q)"
lemmas diagonal_step_PQ_def = diagonal_step_PQ.simps
lemma from_nat_neq_rows:
fixes A::"'a^'cols::mod_type^'rows::mod_type"
assumes i: "i<(nrows A)" and k: "k<(nrows A)" and ik: "i ≠ k"
shows "from_nat i ≠ (from_nat k::'rows)"
proof (rule ccontr, auto)
let ?i="from_nat i::'rows"
let ?k="from_nat k::'rows"
assume "?i = ?k"
hence "to_nat ?i = to_nat ?k" by auto
hence "i = k"
unfolding to_nat_from_nat_id[OF i[unfolded nrows_def]]
unfolding to_nat_from_nat_id[OF k[unfolded nrows_def]] .
thus False using ik by contradiction
qed
lemma from_nat_neq_cols:
fixes A::"'a^'cols::mod_type^'rows::mod_type"
assumes i: "i<(ncols A)" and k: "k<(ncols A)" and ik: "i ≠ k"
shows "from_nat i ≠ (from_nat k::'cols)"
proof (rule ccontr, auto)
let ?i="from_nat i::'cols"
let ?k="from_nat k::'cols"
assume "?i = ?k"
hence "to_nat ?i = to_nat ?k" by auto
hence "i = k"
unfolding to_nat_from_nat_id[OF i[unfolded ncols_def]]
unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]] .
thus False using ik by contradiction
qed
lemma diagonal_step_PQ_invertible_P:
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
and i_not_k: "i ≠ k"
and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)"
shows "invertible P"
proof -
let ?step1 = "(row_add (mat 1) (from_nat k::'rows) (from_nat i) p)"
let ?step2 = "interchange_rows ?step1 (from_nat i) (from_nat k)"
let ?step3 = "row_add (?step2) (from_nat k) (from_nat i) (- v)"
have p: "p = fst (bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k))"
using pquvd by (metis fst_conv)
have v: "-v = (- fst (snd (snd (snd (bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k))))))"
using pquvd by (metis fst_conv snd_conv)
have i_not_k2: "from_nat k ≠ (from_nat i::'rows)"
by (rule from_nat_neq_rows, insert i k i_not_k, auto)
have "invertible ?step3"
unfolding row_add_mat_1[of _ _ _ ?step2, symmetric]
proof (rule invertible_mult)
show "invertible (row_add (mat 1) (from_nat k::'rows) (from_nat i) (- v))"
by (rule invertible_row_add[OF i_not_k2])
show "invertible ?step2"
by (metis i_not_k2 interchange_rows_mat_1 invertible_interchange_rows
invertible_mult invertible_row_add)
qed
thus ?thesis
using PQ p v unfolding diagonal_step_PQ_def Let_def split_beta
by auto
qed
lemma diagonal_step_PQ_invertible_Q:
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
and i_not_k: "i ≠ k"
and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)"
shows "invertible Q"
proof -
let ?step1 = "column_add (mat 1) (from_nat i::'cols) (from_nat k) q"
let ?step2 = "column_add ?step1 (from_nat k) (from_nat i) u"
let ?step3 = "mult_column ?step2 (from_nat k) (- 1)"
have u: "u = (fst (snd (snd (bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)))))"
by (metis fst_conv pquvd snd_conv)
have q: "q = (fst (snd (bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k))))"
by (metis fst_conv pquvd snd_conv)
have "invertible ?step3"
unfolding column_add_mat_1[of _ _ _ ?step2, symmetric]
unfolding mult_column_mat_1[of ?step2, symmetric]
proof (rule invertible_mult)
show "invertible (mult_column (mat 1) (from_nat k::'cols) (- 1::'a))"
by (rule invertible_mult_column[of _ "-1"], auto)
show "invertible ?step2"
by (metis column_add_mat_1 i i_not_k invertible_column_add invertible_mult k
min_less_iff_conj ncols_def to_nat_from_nat_id)
qed
thus ?thesis
using PQ pquvd u q unfolding diagonal_step_PQ_def
by (auto simp add: Let_def split_beta)
qed
lemma mat_q_1[simp]: "mat q $ a $ a = q" unfolding mat_def by auto
lemma mat_q_0[simp]:
assumes ab: "a ≠ b"
shows "mat q $ a $ b = 0" using ab unfolding mat_def by auto
text‹This is an alternative definition for the matrix P in each step, where entries are
given explicitly instead of being computed as a composition of elementary operations. ›
lemma diagonal_step_PQ_P_alt:
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)" and ik: "i ≠ k"
shows "
P = (χ a b.
if a = from_nat i ∧ b = from_nat i then p else
if a = from_nat i ∧ b = from_nat k then 1 else
if a = from_nat k ∧ b = from_nat i then -v * p + 1 else
if a = from_nat k ∧ b = from_nat k then -v else
if a = b then 1 else 0)"
proof -
have ik1: "from_nat i ≠ (from_nat k::'rows)"
using from_nat_neq_rows i ik k by auto
have "P $ a $ b =
(if a = from_nat i ∧ b = from_nat i then p
else if a = from_nat i ∧ b = from_nat k then 1
else if a = from_nat k ∧ b = from_nat i then - v * p + 1
else if a = from_nat k ∧ b = from_nat k then - v else if a = b then 1 else 0)"
for a b
using PQ ik1 pquvd
unfolding diagonal_step_PQ_def
unfolding row_add_def interchange_rows_def
by (auto simp add: Let_def split_beta)
(metis (mono_tags, hide_lams) fst_conv snd_conv)+
thus ?thesis unfolding vec_eq_iff unfolding vec_lambda_beta by auto
qed
text‹This is an alternative definition for the matrix Q in each step, where entries are
given explicitly instead of being computed as a composition of elementary operations.›
lemma diagonal_step_PQ_Q_alt:
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)" and ik: "i ≠ k"
shows "
Q = (χ a b.
if a = from_nat i ∧ b = from_nat i then 1 else
if a = from_nat i ∧ b = from_nat k then -u else
if a = from_nat k ∧ b = from_nat i then q else
if a = from_nat k ∧ b = from_nat k then -q*u-1 else
if a = b then 1 else 0)"
proof -
have ik1: "from_nat i ≠ (from_nat k::'cols)"
using from_nat_neq_cols i ik k by auto
have "Q $ a $ b =
(if a = from_nat i ∧ b = from_nat i then 1 else
if a = from_nat i ∧ b = from_nat k then -u else
if a = from_nat k ∧ b = from_nat i then q else
if a = from_nat k ∧ b = from_nat k then -q*u-1 else
if a = b then 1 else 0)" for a b
using PQ ik1 pquvd unfolding diagonal_step_PQ_def
unfolding column_add_def mult_column_def
by (auto simp add: Let_def split_beta)
(metis (mono_tags, hide_lams) fst_conv snd_conv)+
thus ?thesis unfolding vec_eq_iff unfolding vec_lambda_beta by auto
qed
text‹P**A can be rewriten as elementary operations over A.›
lemma diagonal_step_PQ_PA:
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
shows "P**A = row_add (interchange_rows
(row_add A (from_nat k) (from_nat i) p) (from_nat i) (from_nat k)) (from_nat k) (from_nat i) (- v)"
proof -
let ?i_row = "from_nat i::'rows" and ?k_row = "from_nat k::'rows"
let ?P1 = "row_add (mat 1) ?k_row ?i_row p"
let ?P2' = "interchange_rows ?P1 ?i_row ?k_row"
let ?P2 = "interchange_rows (mat 1) (from_nat i) (from_nat k)"
let ?P3 = "row_add (mat 1) (from_nat k) (from_nat i) (- v)"
have "P = row_add ?P2' ?k_row ?i_row (- v)"
using PQ b unfolding diagonal_step_PQ_def
by (auto simp add: Let_def split_beta, metis fstI sndI)
also have "... = ?P3 ** ?P2'"
unfolding row_add_mat_1[of _ _ _ ?P2', symmetric] by auto
also have "... = ?P3 ** (?P2 ** ?P1)"
unfolding interchange_rows_mat_1[of _ _ ?P1, symmetric] by auto
also have "... ** A = row_add (interchange_rows
(row_add A (from_nat k) (from_nat i) p) (from_nat i) (from_nat k)) (from_nat k) (from_nat i) (- v)"
by (metis interchange_rows_mat_1 matrix_mul_assoc row_add_mat_1)
finally show ?thesis .
qed
lemma diagonal_step_PQ_PAQ':
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
shows "P**A**Q = (mult_column (column_add (column_add (P**A) (from_nat i) (from_nat k) q)
(from_nat k) (from_nat i) u) (from_nat k) (- 1))"
proof -
let ?i_col = "from_nat i::'cols" and ?k_col = "from_nat k::'cols"
let ?Q1="(column_add (mat 1) ?i_col ?k_col q)"
let ?Q2' = "(column_add ?Q1 ?k_col ?i_col u)"
let ?Q2 = "column_add (mat 1) (from_nat k) (from_nat i) u"
let ?Q3 = "mult_column (mat 1) (from_nat k) (- 1)"
have "Q = mult_column ?Q2' ?k_col (-1)"
using PQ b unfolding diagonal_step_PQ_def
by (auto simp add: Let_def split_beta, metis fstI sndI)
also have "... = ?Q2' ** ?Q3"
unfolding mult_column_mat_1[of ?Q2', symmetric] by auto
also have "... = (?Q1**?Q2)**?Q3"
unfolding column_add_mat_1[of ?Q1, symmetric] by auto
also have " (P**A) ** ((?Q1**?Q2)**?Q3) =
(mult_column (column_add (column_add (P**A) ?i_col ?k_col q) ?k_col ?i_col u) ?k_col (- 1))"
by (metis (no_types, lifting) column_add_mat_1 matrix_mul_assoc mult_column_mat_1)
finally show ?thesis .
qed
corollary diagonal_step_PQ_PAQ:
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
shows "P**A**Q = (mult_column (column_add (column_add (row_add (interchange_rows
(row_add A (from_nat k) (from_nat i) p) (from_nat i)
(from_nat k)) (from_nat k) (from_nat i) (- v)) (from_nat i) (from_nat k) q)
(from_nat k) (from_nat i) u) (from_nat k) (- 1))"
using diagonal_step_PQ_PA diagonal_step_PQ_PAQ' assms by metis
lemma isDiagonal_imp_0:
assumes "isDiagonal A"
and "from_nat a ≠ from_nat b"
and "a < min (nrows A) (ncols A)"
and "b < min (nrows A) (ncols A)"
shows "A $ from_nat a $ from_nat b = 0"
by (metis assms isDiagonal min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id)
lemma diagonal_step_PQ:
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)" and ik: "i ≠ k"
and ib: "is_bezout_ext bezout" and diag: "isDiagonal A"
shows "diagonal_step A i k d v = P**A**Q"
proof -
let ?i_row = "from_nat i::'rows"
and ?k_row = "from_nat k::'rows" and ?i_col = "from_nat i::'cols" and ?k_col = "from_nat k::'cols"
let ?P1 = "(row_add (mat 1) ?k_row ?i_row p)"
let ?Aii = "A $ ?i_row $ ?i_col"
let ?Akk = "A $ ?k_row $ ?k_col"
have k1: "k<ncols A" and k2: "k<nrows A" and i1: "i<nrows A" and i2: "i<ncols A" using i k by auto
have Aik0: "A $ ?i_row $ ?k_col = 0"
by (metis diag i ik isDiagonal k min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id)
have Aki0: "A $ ?k_row $ ?i_col = 0"
by (metis diag i ik isDiagonal k min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id)
have du: "d * u = - A $ ?k_row $ ?k_col"
using b ib unfolding is_bezout_ext_def
by (auto simp add: split_beta) (metis fst_conv snd_conv)
have dv: "d * v = A $ ?i_row $ ?i_col"
using b ib unfolding is_bezout_ext_def
by (auto simp add: split_beta) (metis fst_conv snd_conv)
have d: "d = p * ?Aii + ?Akk * q"
using b ib unfolding is_bezout_ext_def
by (auto simp add: split_beta) (metis fst_conv mult.commute snd_conv)
have "(?Aii - v * (p * ?Aii) - v * ?Akk * q) * u = (?Aii - v * ((p * ?Aii) + ?Akk * q)) * u"
by (simp add: diff_diff_add distrib_left mult.assoc)
also have "... = (?Aii*u - d* v *u)"
by (simp add: mult.commute right_diff_distrib d)
also have "... = 0" by (simp add: dv)
finally have rw: "(?Aii - v * (p * ?Aii) - v * ?Akk * q) * u = 0" .
have a1: "from_nat k ≠ (from_nat i::'rows)"
using from_nat_neq_rows i ik k by auto
have a2: "from_nat k ≠ (from_nat i::'cols)"
using from_nat_neq_cols i ik k by auto
have Aab0: "A $ a $ from_nat b = 0" if ab: "a ≠ from_nat b" and b_ncols: "b < ncols A" for a b
by (metis ab b_ncols diag from_nat_to_nat_id isDiagonal ncols_def to_nat_from_nat_id)
have Aab0': "A $ from_nat a $ b = 0" if ab: "from_nat a ≠ b" and a_nrows: "a < nrows A" for a b
by (metis ab a_nrows diag from_nat_to_nat_id isDiagonal nrows_def to_nat_from_nat_id)
show ?thesis
proof (unfold diagonal_step_def vec_eq_iff, auto)
show "d = (P ** A ** Q) $ from_nat i $ from_nat i"
and "d = (P ** A ** Q) $ from_nat i $ from_nat i"
and "d = (P ** A ** Q) $ from_nat i $ from_nat i"
unfolding diagonal_step_PQ_PAQ[OF PQ b]
unfolding mult_column_def column_add_def interchange_rows_def row_add_def
unfolding vec_lambda_beta using a1 a2
using Aik0 Aki0 d by auto
show "v * A $ from_nat k $ from_nat k = (P ** A ** Q) $ from_nat k $ from_nat k"
and "v * A $ from_nat k $ from_nat k = (P ** A ** Q) $ from_nat k $ from_nat k"
using a1 a2
unfolding diagonal_step_PQ_PAQ[OF PQ b] mult_column_def column_add_def
unfolding interchange_rows_def row_add_def
unfolding vec_lambda_beta unfolding Aik0 Aki0 by (auto simp add: rw)
fix a::'rows and b::'cols
assume ak: "a ≠ from_nat k" and ai: "a ≠ from_nat i"
show "A $ a $ b = (P ** A ** Q) $ a $ b"
using ai ak a1 a2 Aab0 k1 i2
unfolding diagonal_step_PQ_PAQ[OF PQ b]
unfolding mult_column_def column_add_def interchange_rows_def row_add_def
unfolding vec_lambda_beta by auto
next
fix a::'rows and b::'cols
assume ak: "a ≠ from_nat k" and ai: "b ≠ from_nat i"
show "A $ a $ b = (P ** A ** Q) $ a $ b"
using ai ak a1 a2 Aab0 Aab0' d du k1 k2 i1 i2
unfolding diagonal_step_PQ_PAQ[OF PQ b]
unfolding mult_column_def column_add_def interchange_rows_def row_add_def
unfolding vec_lambda_beta by auto
next
fix a::'rows and b::'cols
assume ak: "b ≠ from_nat k" and ai: "a ≠ from_nat i"
show "A $ a $ b = (P ** A ** Q) $ a $ b"
using ai ak a1 a2 Aab0 Aab0' d du k1 k2 i1 i2
unfolding diagonal_step_PQ_PAQ[OF PQ b]
unfolding mult_column_def column_add_def interchange_rows_def row_add_def
unfolding vec_lambda_beta apply auto
proof -
assume "d = p * ?Aii+ ?Akk* q"
then have "v * (p * ?Aii) + v * (?Akk* q) = d * v"
by (simp add: ring_class.ring_distribs(1) semiring_normalization_rules(7))
then have "?Aii- v * (p * ?Aii) - v * (?Akk* q) = 0"
by (simp add: diff_diff_add dv)
then show "?Aii- v * (p * ?Aii) = v * ?Akk* q"
by force
qed
next
fix a::'rows and b::'cols
assume ak: "b ≠ from_nat k" and ai: "b ≠ from_nat i"
show "A $ a $ b = (P ** A ** Q) $ a $ b"
using ai ak a1 a2 Aab0 Aab0' d du k1 k2 i1 i2
unfolding diagonal_step_PQ_PAQ[OF PQ b]
unfolding mult_column_def column_add_def interchange_rows_def row_add_def
unfolding vec_lambda_beta by auto
qed
qed
fun diagonal_to_Smith_i_PQ ::
"nat list ⇒ nat ⇒ ('a::{bezout_ring} bezout)
⇒ (('a^'rows::mod_type^'rows::mod_type)×('a^'cols::mod_type^'rows::mod_type)× ('a^'cols::mod_type^'cols::mod_type))
⇒ (('a^'rows::mod_type^'rows::mod_type)× ('a^'cols::mod_type^'rows::mod_type) × ('a^'cols::mod_type^'cols::mod_type))"
where
"diagonal_to_Smith_i_PQ [] i bezout (P,A,Q) = (P,A,Q)" |
"diagonal_to_Smith_i_PQ (j#xs) i bezout (P,A,Q) = (
if A $ (from_nat i) $ (from_nat i) dvd A $ (from_nat j) $ (from_nat j)
then diagonal_to_Smith_i_PQ xs i bezout (P,A,Q)
else let (p, q, u, v, d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j);
A' = diagonal_step A i j d v;
(P',Q') = diagonal_step_PQ A i j bezout
in diagonal_to_Smith_i_PQ xs i bezout (P'**P,A',Q**Q')
)
"
text‹This is implemented by fun. This way, I can do pattern-matching for $(P,A,Q)$.›
fun Diagonal_to_Smith_row_i_PQ
where "Diagonal_to_Smith_row_i_PQ i bezout (P,A,Q)
= diagonal_to_Smith_i_PQ [i + 1..<min (nrows A) (ncols A)] i bezout (P,A,Q)"
text‹Deleted from the simplified and renamed as it would be a definition.›
declare Diagonal_to_Smith_row_i_PQ.simps[simp del]
lemmas Diagonal_to_Smith_row_i_PQ_def = Diagonal_to_Smith_row_i_PQ.simps
fun diagonal_to_Smith_aux_PQ
where
"diagonal_to_Smith_aux_PQ [] bezout (P,A,Q) = (P,A,Q)" |
"diagonal_to_Smith_aux_PQ (i#xs) bezout (P,A,Q)
= diagonal_to_Smith_aux_PQ xs bezout (Diagonal_to_Smith_row_i_PQ i bezout (P,A,Q))"
lemma diagonal_to_Smith_aux_PQ_append:
"diagonal_to_Smith_aux_PQ (xs @ ys) bezout (P,A,Q)
= diagonal_to_Smith_aux_PQ ys bezout (diagonal_to_Smith_aux_PQ xs bezout (P,A,Q))"
by (induct xs bezout "(P,A,Q)" arbitrary: P A Q rule: diagonal_to_Smith_aux_PQ.induct)
(auto, metis prod_cases3)
lemma diagonal_to_Smith_aux_PQ_append2[simp]:
"diagonal_to_Smith_aux_PQ (xs @ [ys]) bezout (P,A,Q)
= Diagonal_to_Smith_row_i_PQ ys bezout (diagonal_to_Smith_aux_PQ xs bezout (P,A,Q))"
proof (induct xs bezout "(P,A,Q)" arbitrary: P A Q rule: diagonal_to_Smith_aux_PQ.induct)
case (1 bezout P A Q)
then show ?case
by (metis append.simps(1) diagonal_to_Smith_aux_PQ.simps prod.exhaust)
next
case (2 i xs bezout P A Q)
then show ?case
by (metis (no_types, hide_lams) append_Cons diagonal_to_Smith_aux_PQ.simps(2) prod_cases3)
qed
context
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
and B::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
and P and Q
and bezout::"'a bezout"
assumes PAQ: "P**A**Q = B"
and P: "invertible P" and Q: "invertible Q"
and ib: "is_bezout_ext bezout"
begin
text‹The output is the same as the one in the version where $P$ and $Q$ are not computed.›
lemma diagonal_to_Smith_i_PQ_eq:
assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_i_PQ xs i bezout (P,B,Q)"
and xs: "∀x. x ∈ set xs ⟶ x < min (nrows A) (ncols A)"
and diag: "isDiagonal B" and i_notin: "i ∉ set xs" and i: "i<min (nrows A) (ncols A)"
shows "B' = diagonal_to_Smith_i xs B i bezout"
using assms PAQ ib P Q
proof (induct xs i bezout "(P,B,Q)" arbitrary: P B Q rule:diagonal_to_Smith_i_PQ.induct)
case (1 i bezout P A Q)
then show ?case by auto
next
case (2 j xs i bezout P B Q)
let ?Bii = "B $ from_nat i $ from_nat i"
let ?Bjj = "B $ from_nat j $ from_nat j"
let ?p="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ p"
let ?q="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ q"
let ?u="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ u"
let ?v="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
let ?d="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
let ?B'="diagonal_step B i j ?d ?v"
let ?P' = "fst (diagonal_step_PQ B i j bezout)"
let ?Q' = "snd (diagonal_step_PQ B i j bezout)"
have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j)"
by (simp add: split_beta)
note hyp = "2.hyps"(2)
note P'B'Q' = "2.prems"(1)
note i_min = "2.prems"(5)
note PAQ_B = "2.prems"(6)
note i_notin = "2.prems"(4)
note diagB = "2.prems"(3)
note xs_min = "2.prems"(2)
note ib = "2.prems"(7)
note inv_P = "2.prems"(8)
note inv_Q = "2.prems"(9)
show ?case
proof (cases "?Bii dvd ?Bjj")
case True
show ?thesis using "2.prems" "2.hyps"(1) True by auto
next
case False
have aux: "diagonal_to_Smith_i_PQ (j # xs) i bezout (P, B, Q)
= diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')"
using False by (auto simp add: split_beta)
have i: "i < min (nrows B) (ncols B)" using i_min unfolding nrows_def ncols_def by auto
have j: "j < min (nrows B) (ncols B)" using xs_min unfolding nrows_def ncols_def by auto
have aux2: "diagonal_to_Smith_i(j # xs) B i bezout = diagonal_to_Smith_i xs ?B' i bezout"
using False by (auto simp add: split_beta)
have res: " B' = diagonal_to_Smith_i xs ?B' i bezout"
proof (rule hyp[OF False])
show "(P', B', Q') = diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')"
using aux P'B'Q' by auto
have B'_P'B'Q': "?B' = ?P'**B**?Q'"
by (rule diagonal_step_PQ[OF _ _ i j _ ib diagB], insert i_notin pquvd, auto)
show "?P'**P ** A ** (Q**?Q') = ?B'"
unfolding B'_P'B'Q' unfolding PAQ_B[symmetric]
by (simp add: matrix_mul_assoc)
show "isDiagonal ?B'" by (rule isDiagonal_diagonal_step[OF diagB i j])
show "invertible (?P'** P)"
by (metis inv_P diagonal_step_PQ_invertible_P i i_notin in_set_member
invertible_mult j member_rec(1) prod.exhaust_sel)
show "invertible (Q ** ?Q')"
by (metis diagonal_step_PQ_invertible_Q i i_notin inv_Q
invertible_mult j list.set_intros(1) prod.collapse)
qed (insert pquvd xs_min i_min i_notin ib, auto)
show ?thesis using aux aux2 res by auto
qed
qed
lemma diagonal_to_Smith_i_PQ':
assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_i_PQ xs i bezout (P,B,Q)"
and xs: "∀x. x ∈ set xs ⟶ x < min (nrows A) (ncols A)"
and diag: "isDiagonal B" and i_notin: "i ∉ set xs" and i: "i<min (nrows A) (ncols A)"
shows "B' = P'**A**Q' ∧ invertible P' ∧ invertible Q'"
using assms PAQ ib P Q
proof (induct xs i bezout "(P,B,Q)" arbitrary: P B Q rule:diagonal_to_Smith_i_PQ.induct)
case (1 i bezout)
then show ?case using PAQ by auto
next
case (2 j xs i bezout P B Q)
let ?Bii = "B $ from_nat i $ from_nat i"
let ?Bjj = "B $ from_nat j $ from_nat j"
let ?p="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ p"
let ?q="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ q"
let ?u="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ u"
let ?v="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ v"
let ?d="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d) ⇒ d"
let ?B'="diagonal_step B i j ?d ?v"
let ?P' = "fst (diagonal_step_PQ B i j bezout)"
let ?Q' = "snd (diagonal_step_PQ B i j bezout)"
have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j)"
by (simp add: split_beta)
show ?case
proof (cases "?Bii dvd ?Bjj")
case True
then show ?thesis using "2.prems"
using "2.hyps"(1) by auto
next
case False
note hyp = "2.hyps"(2)
note P'B'Q' = "2.prems"(1)
note i_min = "2.prems"(5)
note PAQ_B = "2.prems"(6)
note i_notin = "2.prems"(4)
note diagB = "2.prems"(3)
note xs_min = "2.prems"(2)
note ib = "2.prems"(7)
note inv_P = "2.prems"(8)
note inv_Q = "2.prems"(9)
have aux: "diagonal_to_Smith_i_PQ (j # xs) i bezout (P, B, Q)
= diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')"
using False by (auto simp add: split_beta)
have i: "i < min (nrows B) (ncols B)" using i_min unfolding nrows_def ncols_def by auto
have j: "j < min (nrows B) (ncols B)" using xs_min unfolding nrows_def ncols_def by auto
show ?thesis
proof (rule hyp[OF False])
show "(P', B', Q') = diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')"
using aux P'B'Q' by auto
have B'_P'B'Q': "?B' = ?P'**B**?Q'"
by (rule diagonal_step_PQ[OF _ _ i j _ ib diagB], insert i_notin pquvd, auto)
show "?P'**P ** A ** (Q**?Q') = ?B'"
unfolding B'_P'B'Q' unfolding PAQ_B[symmetric]
by (simp add: matrix_mul_assoc)
show "isDiagonal ?B'" by (rule isDiagonal_diagonal_step[OF diagB i j])
show "invertible (?P'** P)"
by (metis inv_P diagonal_step_PQ_invertible_P i i_notin in_set_member
invertible_mult j member_rec(1) prod.exhaust_sel)
show "invertible (Q ** ?Q')"
by (metis diagonal_step_PQ_invertible_Q i i_notin inv_Q
invertible_mult j list.set_intros(1) prod.collapse)
qed (insert pquvd xs_min i_min i_notin ib, auto)
qed
qed
corollary diagonal_to_Smith_i_PQ:
assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_i_PQ xs i bezout (P,B,Q)"
and xs: "∀x. x ∈ set xs ⟶ x < min (nrows A) (ncols A)"
and diag: "isDiagonal B" and i_notin: "i ∉ set xs" and i: "i<min (nrows A) (ncols A)"
shows "B' = P'**A**Q' ∧ invertible P' ∧ invertible Q' ∧ B' = diagonal_to_Smith_i xs B i bezout"
using assms diagonal_to_Smith_i_PQ' diagonal_to_Smith_i_PQ_eq by metis
lemma Diagonal_to_Smith_row_i_PQ_eq:
assumes P'B'Q': "(P',B',Q') = Diagonal_to_Smith_row_i_PQ i bezout (P,B,Q)"
and diag: "isDiagonal B" and i: "i < min (nrows A) (ncols A)"
shows "B' = Diagonal_to_Smith_row_i B i bezout"
using assms unfolding Diagonal_to_Smith_row_i_def Diagonal_to_Smith_row_i_PQ_def
using diagonal_to_Smith_i_PQ by (auto simp add: nrows_def ncols_def)
lemma Diagonal_to_Smith_row_i_PQ':
assumes P'B'Q': "(P',B',Q') = Diagonal_to_Smith_row_i_PQ i bezout (P,B,Q)"
and diag: "isDiagonal B" and i: "i < min (nrows A) (ncols A)"
shows "B' = P'**A**Q' ∧ invertible P' ∧ invertible Q'"
by (rule diagonal_to_Smith_i_PQ'[OF P'B'Q'[unfolded Diagonal_to_Smith_row_i_PQ_def] _ diag _ i],
auto simp add: nrows_def ncols_def)
lemma Diagonal_to_Smith_row_i_PQ:
assumes P'B'Q': "(P',B',Q') = Diagonal_to_Smith_row_i_PQ i bezout (P,B,Q)"
and diag: "isDiagonal B" and i: "i < min (nrows A) (ncols A)"
shows "B' = P'**A**Q' ∧ invertible P' ∧ invertible Q' ∧ B' = Diagonal_to_Smith_row_i B i bezout"
using assms Diagonal_to_Smith_row_i_PQ' Diagonal_to_Smith_row_i_PQ_eq by presburger
end
context
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
and B::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
and P and Q
and bezout::"'a bezout"
assumes PAQ: "P**A**Q = B"
and P: "invertible P" and Q: "invertible Q"
and ib: "is_bezout_ext bezout"
begin
lemma diagonal_to_Smith_aux_PQ:
assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_aux_PQ [0..<k] bezout (P,B,Q)"
and diag: "isDiagonal B" and k:"k<min (nrows A) (ncols A)"
shows "B' = P'**A**Q' ∧ invertible P' ∧ invertible Q' ∧ B' = diagonal_to_Smith_aux B [0..<k] bezout"
using k P'B'Q' P Q PAQ diag
proof (induct k arbitrary: P B Q P' Q' B')
case 0
then show ?case using P Q PAQ by auto
next
case (Suc k P B Q P' Q' B')
note Suc_k = Suc.prems(1)
note PBQ = Suc.prems(2)
note P = Suc.prems(3)
note Q = Suc.prems(4)
note PAQ_B = Suc.prems(5)
note diag_B = Suc.prems(6)
let ?Dk = "(diagonal_to_Smith_aux_PQ [0..<k] bezout (P, P ** A ** Q, Q))"
let ?P' = "fst ?Dk"
let ?B'="fst (snd ?Dk)"
let ?Q' = "snd (snd ?Dk)"
have k: "k<min (nrows A) (ncols A)" using Suc_k by auto
have hyp: "?B' = ?P' ** A ** ?Q' ∧ invertible ?P' ∧ invertible ?Q'
∧ ?B' = diagonal_to_Smith_aux B [0..<k] bezout"
by (rule Suc.hyps[OF k _ P Q PAQ_B diag_B], auto simp add: PAQ_B)
have diag_B': "isDiagonal ?B'"
by (metis diag_B hyp ib isDiagonal_diagonal_to_Smith_aux k ncols_def nrows_def)
have "B' = diagonal_to_Smith_aux B [0..<Suc k] bezout"
by (auto, metis Diagonal_to_Smith_row_i_PQ_eq PAQ_B Suc(3) diag_B'
diagonal_to_Smith_aux_PQ_append2 eq_fst_iff hyp ib k sndI upt.simps(2) zero_order(1))
moreover have "B' = P' ** A ** Q' ∧ invertible P' ∧ invertible Q'"
proof (rule Diagonal_to_Smith_row_i_PQ')
show "(P', B', Q') = Diagonal_to_Smith_row_i_PQ k bezout (?P',?B',?Q')" using Suc.prems by auto
show "invertible ?P'" using hyp by auto
show "?P' ** A ** ?Q' = ?B'" using hyp by auto
show "invertible ?Q'" using hyp by auto
show "is_bezout_ext bezout" using ib by auto
show "k < min (nrows A) (ncols A)" using k by auto
show diag_B': "isDiagonal ?B'" using diag_B' by auto
qed
ultimately show ?case by auto
qed
end
fun diagonal_to_Smith_PQ
where "diagonal_to_Smith_PQ A bezout
= diagonal_to_Smith_aux_PQ [0..<min (nrows A) (ncols A) - 1] bezout (mat 1, A ,mat 1)"
declare diagonal_to_Smith_PQ.simps[simp del]
lemmas diagonal_to_Smith_PQ_def = diagonal_to_Smith_PQ.simps
lemma diagonal_to_Smith_PQ:
fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
assumes A: "isDiagonal A" and ib: "is_bezout_ext bezout"
assumes PBQ: "(P,B,Q) = diagonal_to_Smith_PQ A bezout"
shows "B = P**A**Q ∧ invertible P ∧ invertible Q ∧ B = diagonal_to_Smith A bezout"
proof (unfold diagonal_to_Smith_def, rule diagonal_to_Smith_aux_PQ[OF _ _ _ ib _ A])
let ?P = "mat 1::'a^'rows::mod_type^'rows::mod_type"
let ?Q = "mat 1::'a^'cols::mod_type^'cols::mod_type"
show "(P, B, Q) = diagonal_to_Smith_aux_PQ [0..<min (nrows A) (ncols A) - 1] bezout (?P, A, ?Q)"
using PBQ unfolding diagonal_to_Smith_PQ_def .
show "?P ** A ** ?Q = A" by simp
show " min (nrows A) (ncols A) - 1 < min (nrows A) (ncols A)"
by (metis (no_types, lifting) One_nat_def diff_less dual_order.strict_iff_order le_less_trans
min_def mod_type_class.to_nat_less_card ncols_def not_less_eq nrows_not_0 zero_order(1))
qed (auto simp add: invertible_mat_1)
lemma diagonal_to_Smith_PQ_exists:
fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
assumes A: "isDiagonal A"
shows "∃P Q.
invertible (P::'a^'rows::{mod_type}^'rows::{mod_type})
∧ invertible (Q::'a^'cols::{mod_type}^'cols::{mod_type})
∧ Smith_normal_form (P**A**Q)"
proof -
obtain bezout::"'a bezout" where ib: "is_bezout_ext bezout"
using exists_bezout_ext by blast
obtain P B Q where PBQ: "(P,B,Q) = diagonal_to_Smith_PQ A bezout"
by (metis prod_cases3)
have "B = P**A**Q ∧ invertible P ∧ invertible Q ∧ B = diagonal_to_Smith A bezout"
by (rule diagonal_to_Smith_PQ[OF A ib PBQ])
moreover have "Smith_normal_form (P**A**Q)"
using Smith_normal_form_diagonal_to_Smith assms calculation ib by fastforce
ultimately show ?thesis by auto
qed
subsection‹The final soundness theorem›
lemma diagonal_to_Smith_PQ':
fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
assumes A: "isDiagonal A" and ib: "is_bezout_ext bezout"
assumes PBQ: "(P,S,Q) = diagonal_to_Smith_PQ A bezout"
shows "S = P**A**Q ∧ invertible P ∧ invertible Q ∧ Smith_normal_form S"
using A PBQ Smith_normal_form_diagonal_to_Smith diagonal_to_Smith_PQ ib by fastforce
end
Theory Mod_Type_Connect
section ‹A new bridge to convert theorems from JNF to HOL Analysis and vice-versa,
based on the @{text "mod_type"} class›
theory Mod_Type_Connect
imports
Perron_Frobenius.HMA_Connect
Rank_Nullity_Theorem.Mod_Type
Gauss_Jordan.Elementary_Operations
begin
text ‹Some lemmas on @{text "Mod_Type.to_nat"} and @{text "Mod_Type.from_nat"} are added to have
them with the same names as the analogous ones for @{text "Bij_Nat.to_nat"}
and @{text "Bij_Nat.to_nat"}.›
lemma inj_to_nat: "inj to_nat" by (simp add: inj_on_def)
lemmas from_nat_inj = from_nat_eq_imp_eq
lemma range_to_nat: "range (to_nat :: 'a :: mod_type ⇒ nat) = {0 ..< CARD('a)}"
by (simp add: bij_betw_imp_surj_on mod_type_class.bij_to_nat)
text ‹This theory is an adaptation of the one presented in @{text "Perron_Frobenius.HMA_Connect"},
but for matrices and vectors where indexes have the @{text "mod_type"} class restriction.
It is worth noting that some definitions still use the old abbreviation for HOL Analysis
(HMA, from HOL Multivariate Analysis) instead of HA. This is done to be consistent with
the existing names in the Perron-Frobenius development›
context includes vec.lifting
begin
end
definition from_hma⇩v :: "'a ^ 'n :: mod_type ⇒ 'a Matrix.vec" where
"from_hma⇩v v = Matrix.vec CARD('n) (λ i. v $h from_nat i)"
definition from_hma⇩m :: "'a ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ 'a Matrix.mat" where
"from_hma⇩m a = Matrix.mat CARD('nr) CARD('nc) (λ (i,j). a $h from_nat i $h from_nat j)"
definition to_hma⇩v :: "'a Matrix.vec ⇒ 'a ^ 'n :: mod_type" where
"to_hma⇩v v = (χ i. v $v to_nat i)"
definition to_hma⇩m :: "'a Matrix.mat ⇒ 'a ^ 'nc :: mod_type ^ 'nr :: mod_type " where
"to_hma⇩m a = (χ i j. a $$ (to_nat i, to_nat j))"
lemma to_hma_from_hma⇩v[simp]: "to_hma⇩v (from_hma⇩v v) = v"
by (auto simp: to_hma⇩v_def from_hma⇩v_def to_nat_less_card)
lemma to_hma_from_hma⇩m[simp]: "to_hma⇩m (from_hma⇩m v) = v"
by (auto simp: to_hma⇩m_def from_hma⇩m_def to_nat_less_card)
lemma from_hma_to_hma⇩v[simp]:
"v ∈ carrier_vec (CARD('n)) ⟹ from_hma⇩v (to_hma⇩v v :: 'a ^ 'n :: mod_type) = v"
by (auto simp: to_hma⇩v_def from_hma⇩v_def to_nat_from_nat_id)
lemma from_hma_to_hma⇩m[simp]:
"A ∈ carrier_mat (CARD('nr)) (CARD('nc)) ⟹ from_hma⇩m (to_hma⇩m A :: 'a ^ 'nc :: mod_type ^ 'nr :: mod_type) = A"
by (auto simp: to_hma⇩m_def from_hma⇩m_def to_nat_from_nat_id)
lemma from_hma⇩v_inj[simp]: "from_hma⇩v x = from_hma⇩v y ⟷ x = y"
by (intro iffI, insert to_hma_from_hma⇩v[of x], auto)
lemma from_hma⇩m_inj[simp]: "from_hma⇩m x = from_hma⇩m y ⟷ x = y"
by(intro iffI, insert to_hma_from_hma⇩m[of x], auto)
definition HMA_V :: "'a Matrix.vec ⇒ 'a ^ 'n :: mod_type ⇒ bool" where
"HMA_V = (λ v w. v = from_hma⇩v w)"
definition HMA_M :: "'a Matrix.mat ⇒ 'a ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ bool" where
"HMA_M = (λ a b. a = from_hma⇩m b)"
definition HMA_I :: "nat ⇒ 'n :: mod_type ⇒ bool" where
"HMA_I = (λ i a. i = to_nat a)"
context includes lifting_syntax
begin
lemma Domainp_HMA_V [transfer_domain_rule]:
"Domainp (HMA_V :: 'a Matrix.vec ⇒ 'a ^ 'n :: mod_type ⇒ bool) = (λ v. v ∈ carrier_vec (CARD('n )))"
by(intro ext iffI, insert from_hma_to_hma⇩v[symmetric], auto simp: from_hma⇩v_def HMA_V_def)
lemma Domainp_HMA_M [transfer_domain_rule]:
"Domainp (HMA_M :: 'a Matrix.mat ⇒ 'a ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ bool)
= (λ A. A ∈ carrier_mat CARD('nr) CARD('nc))"
by (intro ext iffI, insert from_hma_to_hma⇩m[symmetric], auto simp: from_hma⇩m_def HMA_M_def)
lemma Domainp_HMA_I [transfer_domain_rule]:
"Domainp (HMA_I :: nat ⇒ 'n :: mod_type ⇒ bool) = (λ i. i < CARD('n))" (is "?l = ?r")
proof (intro ext)
fix i :: nat
show "?l i = ?r i"
unfolding HMA_I_def Domainp_iff
by (auto intro: exI[of _ "from_nat i"] simp: to_nat_from_nat_id to_nat_less_card)
qed
lemma bi_unique_HMA_V [transfer_rule]: "bi_unique HMA_V" "left_unique HMA_V" "right_unique HMA_V"
unfolding HMA_V_def bi_unique_def left_unique_def right_unique_def by auto
lemma bi_unique_HMA_M [transfer_rule]: "bi_unique HMA_M" "left_unique HMA_M" "right_unique HMA_M"
unfolding HMA_M_def bi_unique_def left_unique_def right_unique_def by auto
lemma bi_unique_HMA_I [transfer_rule]: "bi_unique HMA_I" "left_unique HMA_I" "right_unique HMA_I"
unfolding HMA_I_def bi_unique_def left_unique_def right_unique_def by auto
lemma right_total_HMA_V [transfer_rule]: "right_total HMA_V"
unfolding HMA_V_def right_total_def by simp
lemma right_total_HMA_M [transfer_rule]: "right_total HMA_M"
unfolding HMA_M_def right_total_def by simp
lemma right_total_HMA_I [transfer_rule]: "right_total HMA_I"
unfolding HMA_I_def right_total_def by simp
lemma HMA_V_index [transfer_rule]: "(HMA_V ===> HMA_I ===> (=)) ($v) ($h)"
unfolding rel_fun_def HMA_V_def HMA_I_def from_hma⇩v_def
by (auto simp: to_nat_less_card)
lemma HMA_M_index [transfer_rule]:
"(HMA_M ===> HMA_I ===> HMA_I ===> (=)) (λ A i j. A $$ (i,j)) index_hma"
by (intro rel_funI, simp add: index_hma_def to_nat_less_card HMA_M_def HMA_I_def from_hma⇩m_def)
lemma HMA_V_0 [transfer_rule]: "HMA_V (0⇩v CARD('n)) (0 :: 'a :: zero ^ 'n:: mod_type)"
unfolding HMA_V_def from_hma⇩v_def by auto
lemma HMA_M_0 [transfer_rule]:
"HMA_M (0⇩m CARD('nr) CARD('nc)) (0 :: 'a :: zero ^ 'nc:: mod_type ^ 'nr :: mod_type)"
unfolding HMA_M_def from_hma⇩m_def by auto
lemma HMA_M_1[transfer_rule]:
"HMA_M (1⇩m (CARD('n))) (mat 1 :: 'a::{zero,one}^'n:: mod_type^'n:: mod_type)"
unfolding HMA_M_def
by (auto simp add: mat_def from_hma⇩m_def from_nat_inj)
lemma from_hma⇩v_add: "from_hma⇩v v + from_hma⇩v w = from_hma⇩v (v + w)"
unfolding from_hma⇩v_def by auto
lemma HMA_V_add [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (+) (+) "
unfolding rel_fun_def HMA_V_def
by (auto simp: from_hma⇩v_add)
lemma from_hma⇩v_diff: "from_hma⇩v v - from_hma⇩v w = from_hma⇩v (v - w)"
unfolding from_hma⇩v_def by auto
lemma HMA_V_diff [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (-) (-)"
unfolding rel_fun_def HMA_V_def
by (auto simp: from_hma⇩v_diff)
lemma from_hma⇩m_add: "from_hma⇩m a + from_hma⇩m b = from_hma⇩m (a + b)"
unfolding from_hma⇩m_def by auto
lemma HMA_M_add [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (+) (+) "
unfolding rel_fun_def HMA_M_def
by (auto simp: from_hma⇩m_add)
lemma from_hma⇩m_diff: "from_hma⇩m a - from_hma⇩m b = from_hma⇩m (a - b)"
unfolding from_hma⇩m_def by auto
lemma HMA_M_diff [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (-) (-) "
unfolding rel_fun_def HMA_M_def
by (auto simp: from_hma⇩m_diff)
lemma scalar_product: fixes v :: "'a :: semiring_1 ^ 'n :: mod_type"
shows "scalar_prod (from_hma⇩v v) (from_hma⇩v w) = scalar_product v w"
unfolding scalar_product_def scalar_prod_def from_hma⇩v_def dim_vec
by (simp add: sum.reindex[OF inj_to_nat, unfolded range_to_nat])
lemma [simp]:
"from_hma⇩m (y :: 'a ^ 'nc :: mod_type ^ 'nr:: mod_type) ∈ carrier_mat (CARD('nr)) (CARD('nc))"
"dim_row (from_hma⇩m (y :: 'a ^ 'nc:: mod_type ^ 'nr :: mod_type)) = CARD('nr)"
"dim_col (from_hma⇩m (y :: 'a ^ 'nc :: mod_type ^ 'nr:: mod_type )) = CARD('nc)"
unfolding from_hma⇩m_def by simp_all
lemma [simp]:
"from_hma⇩v (y :: 'a ^ 'n:: mod_type) ∈ carrier_vec (CARD('n))"
"dim_vec (from_hma⇩v (y :: 'a ^ 'n:: mod_type)) = CARD('n)"
unfolding from_hma⇩v_def by simp_all
lemma HMA_scalar_prod [transfer_rule]:
"(HMA_V ===> HMA_V ===> (=)) scalar_prod scalar_product"
by (auto simp: HMA_V_def scalar_product)
lemma HMA_row [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (λ i a. Matrix.row a i) row"
unfolding HMA_M_def HMA_I_def HMA_V_def
by (auto simp: from_hma⇩m_def from_hma⇩v_def to_nat_less_card row_def)
lemma HMA_col [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (λ i a. col a i) column"
unfolding HMA_M_def HMA_I_def HMA_V_def
by (auto simp: from_hma⇩m_def from_hma⇩v_def to_nat_less_card column_def)
lemma HMA_M_mk_mat[transfer_rule]: "((HMA_I ===> HMA_I ===> (=)) ===> HMA_M)
(λ f. Matrix.mat (CARD('nr)) (CARD('nc)) (λ (i,j). f i j))
(mk_mat :: (('nr ⇒ 'nc ⇒ 'a) ⇒ 'a^'nc:: mod_type^'nr:: mod_type))"
proof-
{
fix x y i j
assume id: "∀ (ya :: 'nr) (yb :: 'nc). (x (to_nat ya) (to_nat yb) :: 'a) = y ya yb"
and i: "i < CARD('nr)" and j: "j < CARD('nc)"
from to_nat_from_nat_id[OF i] to_nat_from_nat_id[OF j] id[rule_format, of "from_nat i" "from_nat j"]
have "x i j = y (from_nat i) (from_nat j)" by auto
}
thus ?thesis
unfolding rel_fun_def mk_mat_def HMA_M_def HMA_I_def from_hma⇩m_def by auto
qed
lemma HMA_M_mk_vec[transfer_rule]: "((HMA_I ===> (=)) ===> HMA_V)
(λ f. Matrix.vec (CARD('n)) (λ i. f i))
(mk_vec :: (('n ⇒ 'a) ⇒ 'a^'n:: mod_type))"
proof-
{
fix x y i
assume id: "∀ (ya :: 'n). (x (to_nat ya) :: 'a) = y ya"
and i: "i < CARD('n)"
from to_nat_from_nat_id[OF i] id[rule_format, of "from_nat i"]
have "x i = y (from_nat i)" by auto
}
thus ?thesis
unfolding rel_fun_def mk_vec_def HMA_V_def HMA_I_def from_hma⇩v_def by auto
qed
lemma mat_mult_scalar: "A ** B = mk_mat (λ i j. scalar_product (row i A) (column j B))"
unfolding vec_eq_iff matrix_matrix_mult_def scalar_product_def mk_mat_def
by (auto simp: row_def column_def)
lemma mult_mat_vec_scalar: "A *v v = mk_vec (λ i. scalar_product (row i A) v)"
unfolding vec_eq_iff matrix_vector_mult_def scalar_product_def mk_mat_def mk_vec_def
by (auto simp: row_def column_def)
lemma dim_row_transfer_rule:
"HMA_M A (A' :: 'a ^ 'nc:: mod_type ^ 'nr:: mod_type) ⟹ (=) (dim_row A) (CARD('nr))"
unfolding HMA_M_def by auto
lemma dim_col_transfer_rule:
"HMA_M A (A' :: 'a ^ 'nc:: mod_type ^ 'nr:: mod_type) ⟹ (=) (dim_col A) (CARD('nc))"
unfolding HMA_M_def by auto
lemma HMA_M_mult [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (*) (**)"
proof -
{
fix A B :: "'a :: semiring_1 mat" and A' :: "'a ^ 'n :: mod_type ^ 'nr:: mod_type"
and B' :: "'a ^ 'nc :: mod_type ^ 'n:: mod_type"
assume 1[transfer_rule]: "HMA_M A A'" "HMA_M B B'"
note [transfer_rule] = dim_row_transfer_rule[OF 1(1)] dim_col_transfer_rule[OF 1(2)]
have "HMA_M (A * B) (A' ** B')"
unfolding times_mat_def mat_mult_scalar
by (transfer_prover_start, transfer_step+, transfer, auto)
}
thus ?thesis by blast
qed
lemma HMA_V_smult [transfer_rule]: "((=) ===> HMA_V ===> HMA_V) (⋅⇩v) (*s)"
unfolding smult_vec_def
unfolding rel_fun_def HMA_V_def from_hma⇩v_def
by auto
lemma HMA_M_mult_vec [transfer_rule]: "(HMA_M ===> HMA_V ===> HMA_V) (*⇩v) (*v)"
proof -
{
fix A :: "'a :: semiring_1 mat" and v :: "'a Matrix.vec"
and A' :: "'a ^ 'nc :: mod_type ^ 'nr :: mod_type" and v' :: "'a ^ 'nc :: mod_type"
assume 1[transfer_rule]: "HMA_M A A'" "HMA_V v v'"
note [transfer_rule] = dim_row_transfer_rule
have "HMA_V (A *⇩v v) (A' *v v')"
unfolding mult_mat_vec_def mult_mat_vec_scalar
by (transfer_prover_start, transfer_step+, transfer, auto)
}
thus ?thesis by blast
qed
lemma HMA_det [transfer_rule]: "(HMA_M ===> (=)) Determinant.det
(det :: 'a :: comm_ring_1 ^ 'n :: mod_type ^ 'n :: mod_type ⇒ 'a)"
proof -
{
fix a :: "'a ^ 'n :: mod_type^ 'n:: mod_type"
let ?tn = "to_nat :: 'n :: mod_type ⇒ nat"
let ?fn = "from_nat :: nat ⇒ 'n"
let ?zn = "{0..< CARD('n)}"
let ?U = "UNIV :: 'n set"
let ?p1 = "{p. p permutes ?zn}"
let ?p2 = "{p. p permutes ?U}"
let ?f= "λ p i. if i ∈ ?U then ?fn (p (?tn i)) else i"
let ?g = "λ p i. ?fn (p (?tn i))"
have fg: "⋀ a b c. (if a ∈ ?U then b else c) = b" by auto
have "?p2 = ?f ` ?p1"
by (rule permutes_bij', auto simp: to_nat_less_card to_nat_from_nat_id)
hence id: "?p2 = ?g ` ?p1" by simp
have inj_g: "inj_on ?g ?p1"
unfolding inj_on_def
proof (intro ballI impI ext, auto)
fix p q i
assume p: "p permutes ?zn" and q: "q permutes ?zn"
and id: "(λ i. ?fn (p (?tn i))) = (λ i. ?fn (q (?tn i)))"
{
fix i
from permutes_in_image[OF p] have pi: "p (?tn i) < CARD('n)" by (simp add: to_nat_less_card)
from permutes_in_image[OF q] have qi: "q (?tn i) < CARD('n)" by (simp add: to_nat_less_card)
from fun_cong[OF id] have "?fn (p (?tn i)) = from_nat (q (?tn i))" .
from arg_cong[OF this, of ?tn] have "p (?tn i) = q (?tn i)"
by (simp add: to_nat_from_nat_id pi qi)
} note id = this
show "p i = q i"
proof (cases "i < CARD('n)")
case True
hence "?tn (?fn i) = i" by (simp add: to_nat_from_nat_id)
from id[of "?fn i", unfolded this] show ?thesis .
next
case False
thus ?thesis using p q unfolding permutes_def by simp
qed
qed
have mult_cong: "⋀ a b c d. a = b ⟹ c = d ⟹ a * c = b * d" by simp
have "sum (λ p.
signof p * (∏i∈?zn. a $h ?fn i $h ?fn (p i))) ?p1
= sum (λ p. of_int (sign p) * (∏i∈UNIV. a $h i $h p i)) ?p2"
unfolding id sum.reindex[OF inj_g]
proof (rule sum.cong[OF refl], unfold mem_Collect_eq o_def, rule mult_cong)
fix p
assume p: "p permutes ?zn"
let ?q = "λ i. ?fn (p (?tn i))"
from id p have q: "?q permutes ?U" by auto
from p have pp: "permutation p" unfolding permutation_permutes by auto
let ?ft = "λ p i. ?fn (p (?tn i))"
have fin: "finite ?zn" by simp
have "sign p = sign ?q ∧ p permutes ?zn"
proof (induct rule: permutes_induct[OF fin _ _ p])
case 1
show ?case by (auto simp: sign_id[unfolded id_def] permutes_id[unfolded id_def])
next
case (2 a b p)
let ?sab = "Fun.swap a b id"
let ?sfab = "Fun.swap (?fn a) (?fn b) id"
have p_sab: "permutation ?sab" by (rule permutation_swap_id)
have p_sfab: "permutation ?sfab" by (rule permutation_swap_id)
from 2(3) have IH1: "p permutes ?zn" and IH2: "sign p = sign (?ft p)" by auto
have sab_perm: "?sab permutes ?zn" using 2(1-2) by (rule permutes_swap_id)
from permutes_compose[OF IH1 this] have perm1: "?sab o p permutes ?zn" .
from IH1 have p_p1: "p ∈ ?p1" by simp
hence "?ft p ∈ ?ft ` ?p1" by (rule imageI)
from this[folded id] have "?ft p permutes ?U" by simp
hence p_ftp: "permutation (?ft p)" unfolding permutation_permutes by auto
{
fix a b
assume a: "a ∈ ?zn" and b: "b ∈ ?zn"
hence "(?fn a = ?fn b) = (a = b)" using 2(1-2)
by (auto simp add: from_nat_eq_imp_eq)
} note inj = this
from inj[OF 2(1-2)] have id2: "sign ?sfab = sign ?sab" unfolding sign_swap_id by simp
have id: "?ft (Fun.swap a b id ∘ p) = Fun.swap (?fn a) (?fn b) id ∘ ?ft p"
proof
fix c
show "?ft (Fun.swap a b id ∘ p) c = (Fun.swap (?fn a) (?fn b) id ∘ ?ft p) c"
proof (cases "p (?tn c) = a ∨ p (?tn c) = b")
case True
thus ?thesis by (cases, auto simp add: o_def swap_def)
next
case False
hence neq: "p (?tn c) ≠ a" "p (?tn c) ≠ b" by auto
have pc: "p (?tn c) ∈ ?zn" unfolding permutes_in_image[OF IH1]
by (simp add: to_nat_less_card)
from neq[folded inj[OF pc 2(1)] inj[OF pc 2(2)]]
have "?fn (p (?tn c)) ≠ ?fn a" "?fn (p (?tn c)) ≠ ?fn b" .
with neq show ?thesis by (auto simp: o_def swap_def)
qed
qed
show ?case unfolding IH2 id sign_compose[OF p_sab 2(5)] sign_compose[OF p_sfab p_ftp] id2
by (rule conjI[OF refl perm1])
qed
thus "signof p = of_int (sign ?q)" unfolding signof_def sign_def by auto
show "(∏i = 0..<CARD('n). a $h ?fn i $h ?fn (p i)) =
(∏i∈UNIV. a $h i $h ?q i)" unfolding
range_to_nat[symmetric] prod.reindex[OF inj_to_nat]
by (rule prod.cong[OF refl], unfold o_def, simp)
qed
}
thus ?thesis unfolding HMA_M_def
by (auto simp: from_hma⇩m_def Determinant.det_def det_def)
qed
lemma HMA_mat[transfer_rule]: "((=) ===> HMA_M) (λ k. k ⋅⇩m 1⇩m CARD('n))
(Finite_Cartesian_Product.mat :: 'a::semiring_1 ⇒ 'a^'n :: mod_type^'n :: mod_type)"
unfolding Finite_Cartesian_Product.mat_def[abs_def] rel_fun_def HMA_M_def
by (auto simp: from_hma⇩m_def from_nat_inj)
lemma HMA_mat_minus[transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M)
(λ A B. A + map_mat uminus B) ((-) :: 'a :: group_add ^'nc:: mod_type^'nr:: mod_type
⇒ 'a^'nc:: mod_type^'nr:: mod_type ⇒ 'a^'nc:: mod_type^'nr:: mod_type)"
unfolding rel_fun_def HMA_M_def from_hma⇩m_def by auto
lemma HMA_transpose_matrix [transfer_rule]:
"(HMA_M ===> HMA_M) transpose_mat transpose"
unfolding transpose_mat_def transpose_def HMA_M_def from_hma⇩m_def by auto
lemma HMA_invertible_matrix_mod_type[transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'n :: mod_type ^ 'n :: mod_type
⇒ _) ===> (=)) invertible_mat invertible"
proof (intro rel_funI, goal_cases)
case (1 x y)
note rel_xy[transfer_rule] = "1"
have eq_dim: "dim_col x = dim_row x"
using Mod_Type_Connect.dim_col_transfer_rule Mod_Type_Connect.dim_row_transfer_rule rel_xy
by fastforce
moreover have "∃A'. y ** A' = mat 1 ∧ A' ** y = mat 1"
if xB: "x * B = 1⇩m (dim_row x)" and Bx: "B * x = 1⇩m (dim_row B)" for B
proof -
let ?A' = "Mod_Type_Connect.to_hma⇩m B:: 'a :: comm_ring_1 ^ 'n :: mod_type^ 'n :: mod_type"
have rel_BA[transfer_rule]: "Mod_Type_Connect.HMA_M B ?A'"
by (metis (no_types, lifting) Bx Mod_Type_Connect.HMA_M_def eq_dim carrier_mat_triv dim_col_mat(1)
Mod_Type_Connect.from_hma⇩m_def Mod_Type_Connect.from_hma_to_hma⇩m index_mult_mat(3)
index_one_mat(3) rel_xy xB)
have [simp]: "dim_row B = CARD('n)" using Mod_Type_Connect.dim_row_transfer_rule rel_BA by blast
have [simp]: "dim_row x = CARD('n)" using Mod_Type_Connect.dim_row_transfer_rule rel_xy by blast
have "y ** ?A' = mat 1" using xB by (transfer, simp)
moreover have "?A' ** y = mat 1" using Bx by (transfer, simp)
ultimately show ?thesis by blast
qed
moreover have "∃B. x * B = 1⇩m (dim_row x) ∧ B * x = 1⇩m (dim_row B)"
if yA: "y ** A' = mat 1" and Ay: "A' ** y = mat 1" for A'
proof -
let ?B = "(Mod_Type_Connect.from_hma⇩m A')"
have [simp]: "dim_row x = CARD('n)" using rel_xy Mod_Type_Connect.dim_row_transfer_rule by blast
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B A'" by (simp add: Mod_Type_Connect.HMA_M_def)
hence [simp]: "dim_row ?B = CARD('n)" using dim_row_transfer_rule by auto
have "x * ?B = 1⇩m (dim_row x)" using yA by (transfer', auto)
moreover have "?B * x = 1⇩m (dim_row ?B)" using Ay by (transfer', auto)
ultimately show ?thesis by auto
qed
ultimately show ?case unfolding invertible_mat_def invertible_def inverts_mat_def by auto
qed
end
text ‹Some transfer rules for relating the elementary operations are also proved.›
context
includes lifting_syntax
begin
lemma HMA_swaprows[transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ _)
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nr :: mod_type ⇒ _ )
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nr :: mod_type ⇒ _ )
===> Mod_Type_Connect.HMA_M)
(λA a b. swaprows a b A) interchange_rows"
by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def interchange_rows_def)
(rule eq_matI, auto simp add: Mod_Type_Connect.from_hma⇩m_def Mod_Type_Connect.HMA_I_def
to_nat_less_card to_nat_from_nat_id)
lemma HMA_swapcols[transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ _)
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nc :: mod_type ⇒ _ )
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nc :: mod_type ⇒ _ )
===> Mod_Type_Connect.HMA_M)
(λA a b. swapcols a b A) interchange_columns"
by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def interchange_columns_def)
(rule eq_matI, auto simp add: Mod_Type_Connect.from_hma⇩m_def Mod_Type_Connect.HMA_I_def
to_nat_less_card to_nat_from_nat_id)
lemma HMA_addrow[transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ _)
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nr :: mod_type ⇒ _ )
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nr :: mod_type ⇒ _ )
===> (=)
===> Mod_Type_Connect.HMA_M)
(λA a b q. addrow q a b A) row_add"
by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def row_add_def)
(rule eq_matI, auto simp add: Mod_Type_Connect.from_hma⇩m_def Mod_Type_Connect.HMA_I_def
to_nat_less_card to_nat_from_nat_id)
lemma HMA_addcol[transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ _)
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nc :: mod_type ⇒ _ )
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nc :: mod_type ⇒ _ )
===> (=)
===> Mod_Type_Connect.HMA_M)
(λA a b q. addcol q a b A) column_add"
by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def column_add_def)
(rule eq_matI, auto simp add: Mod_Type_Connect.from_hma⇩m_def Mod_Type_Connect.HMA_I_def
to_nat_less_card to_nat_from_nat_id)
lemma HMA_multrow[transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ _)
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nr :: mod_type ⇒ _ )
===> (=)
===> Mod_Type_Connect.HMA_M)
(λA i q. multrow i q A) mult_row"
by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def mult_row_def)
(rule eq_matI, auto simp add: Mod_Type_Connect.from_hma⇩m_def Mod_Type_Connect.HMA_I_def
to_nat_less_card to_nat_from_nat_id)
lemma HMA_multcol[transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ _)
===> (Mod_Type_Connect.HMA_I :: _ ⇒'nc :: mod_type ⇒ _ )
===> (=)
===> Mod_Type_Connect.HMA_M)
(λA i q. multcol i q A) mult_column"
by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def mult_column_def)
(rule eq_matI, auto simp add: Mod_Type_Connect.from_hma⇩m_def Mod_Type_Connect.HMA_I_def
to_nat_less_card to_nat_from_nat_id)
end
fun HMA_M3 where
"HMA_M3 (P,A,Q)
(P' :: 'a :: comm_ring_1 ^ 'nr :: mod_type ^ 'nr :: mod_type,
A' :: 'a ^ 'nc :: mod_type ^ 'nr :: mod_type,
Q' :: 'a ^ 'nc :: mod_type ^ 'nc :: mod_type) =
(Mod_Type_Connect.HMA_M P P' ∧ Mod_Type_Connect.HMA_M A A' ∧ Mod_Type_Connect.HMA_M Q Q')"
lemma HMA_M3_def:
"HMA_M3 A B = (Mod_Type_Connect.HMA_M (fst A) (fst B)
∧ Mod_Type_Connect.HMA_M (fst (snd A)) (fst (snd B))
∧ Mod_Type_Connect.HMA_M (snd (snd A)) (snd (snd B)))"
by (smt HMA_M3.simps prod.collapse)
context
includes lifting_syntax
begin
lemma Domainp_HMA_M3 [transfer_domain_rule]:
"Domainp (HMA_M3 :: _⇒(_×('a::comm_ring_1^'nc::mod_type^'nr::mod_type)×_)⇒_)
= (λ(P,A,Q). P ∈ carrier_mat CARD('nr) CARD('nr) ∧ A ∈ carrier_mat CARD('nr) CARD('nc)
∧ Q ∈ carrier_mat CARD('nc) CARD('nc))"
proof -
let ?HMA_M3 = "HMA_M3::_⇒(_×('a::comm_ring_1^'nc::mod_type^'nr::mod_type)×_)⇒_"
have 1: "P ∈ carrier_mat CARD('nr) CARD('nr) ∧
A ∈ carrier_mat CARD('nr) CARD('nc) ∧ Q ∈ carrier_mat CARD('nc) CARD('nc)"
if "Domainp ?HMA_M3 (P,A,Q)" for P A Q
using that unfolding Domainp_iff by (auto simp add: Mod_Type_Connect.HMA_M_def)
have 2: "Domainp ?HMA_M3 (P,A,Q)" if PAQ: "P ∈ carrier_mat CARD('nr) CARD('nr)
∧ A ∈ carrier_mat CARD('nr) CARD('nc) ∧Q ∈ carrier_mat CARD('nc) CARD('nc)" for P A Q
proof -
let ?P = "Mod_Type_Connect.to_hma⇩m P::'a^'nr::mod_type^'nr::mod_type"
let ?A = "Mod_Type_Connect.to_hma⇩m A::'a^'nc::mod_type^'nr::mod_type"
let ?Q = "Mod_Type_Connect.to_hma⇩m Q::'a^'nc::mod_type^'nc::mod_type"
have "HMA_M3 (P,A,Q) (?P,?A,?Q)"
by (auto simp add: Mod_Type_Connect.HMA_M_def PAQ)
thus ?thesis unfolding Domainp_iff by auto
qed
have "fst x ∈ carrier_mat CARD('nr) CARD('nr) ∧ fst (snd x) ∈ carrier_mat CARD('nr) CARD('nc)
∧ (snd (snd x)) ∈ carrier_mat CARD('nc) CARD('nc)"
if "Domainp ?HMA_M3 x" for x using 1
by (metis (full_types) surjective_pairing that)
moreover have "Domainp ?HMA_M3 x"
if "fst x ∈ carrier_mat CARD('nr) CARD('nr) ∧ fst (snd x) ∈ carrier_mat CARD('nr) CARD('nc)
∧ (snd (snd x)) ∈ carrier_mat CARD('nc) CARD('nc)" for x
using 2
by (metis (full_types) surjective_pairing that)
ultimately show ?thesis by (intro ext iffI, unfold split_beta, metis+)
qed
lemma bi_unique_HMA_M3 [transfer_rule]: "bi_unique HMA_M3" "left_unique HMA_M3" "right_unique HMA_M3"
unfolding HMA_M3_def bi_unique_def left_unique_def right_unique_def
by (auto simp add: Mod_Type_Connect.HMA_M_def)
lemma right_total_HMA_M3 [transfer_rule]: "right_total HMA_M3"
unfolding HMA_M_def right_total_def
by (simp add: Mod_Type_Connect.HMA_M_def)
end
end
Theory SNF_Missing_Lemmas
section ‹Missing results›
theory SNF_Missing_Lemmas
imports
Hermite.Hermite
Mod_Type_Connect
Jordan_Normal_Form.DL_Rank_Submatrix
"List-Index.List_Index"
begin
text ‹This theory presents some missing lemmas that are required for the Smith normal form
development. Some of them could be added to different AFP entries, such as the Jordan Normal
Form AFP entry by Ren\'e Thiemann and Akihisa Yamada.
However, not all the lemmas can be added directly, since some imports are required.›
hide_const (open) C
hide_const (open) measure
subsection ‹Miscellaneous lemmas›
lemma sum_two_rw: "(∑i = 0..<2. f i) = (∑i ∈ {0,1::nat}. f i)"
by (rule sum.cong, auto)
lemma sum_common_left:
fixes f::"'a ⇒ 'b::comm_ring_1"
assumes "finite A"
shows "sum (λi. c * f i) A = c * sum f A"
by (simp add: mult_hom.hom_sum)
lemma prod3_intro:
assumes "fst A = a" and "fst (snd A) = b" and "snd (snd A) = c"
shows "A = (a,b,c)" using assms by auto
subsection ‹Transfer rules for the HMA\_Connect file of the Perron-Frobenius development›
hide_const (open) HMA_M HMA_I to_hma⇩m from_hma⇩m
hide_fact (open) from_hma⇩m_def from_hma_to_hma⇩m HMA_M_def HMA_I_def dim_row_transfer_rule
dim_col_transfer_rule
context
includes lifting_syntax
begin
lemma HMA_invertible_matrix[transfer_rule]:
"((HMA_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'n ^ 'n ⇒ _) ===> (=)) invertible_mat invertible"
proof (intro rel_funI, goal_cases)
case (1 x y)
note rel_xy[transfer_rule] = "1"
have eq_dim: "dim_col x = dim_row x"
using HMA_Connect.dim_col_transfer_rule HMA_Connect.dim_row_transfer_rule rel_xy
by fastforce
moreover have "∃A'. y ** A' = Finite_Cartesian_Product.mat 1 ∧ A' ** y = Finite_Cartesian_Product.mat 1"
if xB: "x * B = 1⇩m (dim_row x)" and Bx: "B * x = 1⇩m (dim_row B)" for B
proof -
let ?A' = "HMA_Connect.to_hma⇩m B:: 'a :: comm_ring_1 ^ 'n ^ 'n"
have rel_BA[transfer_rule]: "HMA_M B ?A'"
by (metis (no_types, lifting) Bx HMA_M_def eq_dim carrier_mat_triv dim_col_mat(1)
from_hma⇩m_def from_hma_to_hma⇩m index_mult_mat(3) index_one_mat(3) rel_xy xB)
have [simp]: "dim_row B = CARD('n)" using dim_row_transfer_rule rel_BA by blast
have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast
have "y ** ?A' = Finite_Cartesian_Product.mat 1" using xB by (transfer, simp)
moreover have "?A' ** y = Finite_Cartesian_Product.mat 1" using Bx by (transfer, simp)
ultimately show ?thesis by blast
qed
moreover have "∃B. x * B = 1⇩m (dim_row x) ∧ B * x = 1⇩m (dim_row B)"
if yA: "y ** A' = Finite_Cartesian_Product.mat 1" and Ay: "A' ** y = Finite_Cartesian_Product.mat 1" for A'
proof -
let ?B = "(from_hma⇩m A')"
have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast
have [transfer_rule]: "HMA_M ?B A'" by (simp add: HMA_M_def)
hence [simp]: "dim_row ?B = CARD('n)" using dim_row_transfer_rule by auto
have "x * ?B = 1⇩m (dim_row x)" using yA by (transfer', auto)
moreover have "?B * x = 1⇩m (dim_row ?B)" using Ay by (transfer', auto)
ultimately show ?thesis by auto
qed
ultimately show ?case unfolding invertible_mat_def invertible_def inverts_mat_def by auto
qed
end
subsection ‹Lemmas obtained from HOL Analysis using local type definitions›
thm Cartesian_Space.invertible_mult
thm invertible_iff_is_unit
thm det_non_zero_imp_unit
thm mat_mult_left_right_inverse
lemma invertible_mat_zero:
assumes A: "A ∈ carrier_mat 0 0"
shows "invertible_mat A"
using A unfolding invertible_mat_def inverts_mat_def one_mat_def times_mat_def scalar_prod_def
Matrix.row_def col_def carrier_mat_def
by (auto, metis (no_types, lifting) cong_mat not_less_zero)
lemma invertible_mult_JNF:
fixes A::"'a::comm_ring_1 mat"
assumes A: "A∈carrier_mat n n" and B: "B∈carrier_mat n n"
and inv_A: "invertible_mat A" and inv_B: "invertible_mat B"
shows "invertible_mat (A*B)"
proof (cases "n = 0")
case True
then show ?thesis using assms
by (simp add: invertible_mat_zero)
next
case False
then show ?thesis using
invertible_mult[where ?'a="'a::comm_ring_1", where ?'b="'n::finite", where ?'c="'n::finite",
where ?'d="'n::finite", untransferred, cancel_card_constraint, OF assms] by auto
qed
lemma invertible_iff_is_unit_JNF:
assumes A: "A ∈ carrier_mat n n"
shows "invertible_mat A ⟷ (Determinant.det A) dvd 1"
proof (cases "n=0")
case True
then show ?thesis using det_dim_zero invertible_mat_zero A by auto
next
case False
then show ?thesis using invertible_iff_is_unit[untransferred, cancel_card_constraint] A by auto
qed
subsection ‹Lemmas about matrices, submatrices and determinants›
thm mat_mult_left_right_inverse
lemma mat_mult_left_right_inverse:
fixes A :: "'a::comm_ring_1 mat"
assumes A: "A ∈ carrier_mat n n"
and B: "B ∈ carrier_mat n n" and AB: "A * B = 1⇩m n"
shows "B * A = 1⇩m n"
proof -
have "Determinant.det (A * B) = Determinant.det (1⇩m n)" using AB by auto
hence "Determinant.det A * Determinant.det B = 1"
using Determinant.det_mult[OF A B] det_one by auto
hence det_A: "(Determinant.det A) dvd 1" and det_B: "(Determinant.det B) dvd 1"
using dvd_triv_left dvd_triv_right by metis+
hence inv_A: "invertible_mat A" and inv_B: "invertible_mat B"
using A B invertible_iff_is_unit_JNF by blast+
obtain B' where inv_BB': "inverts_mat B B'" and inv_B'B: "inverts_mat B' B"
using inv_B unfolding invertible_mat_def by auto
have B'_carrier: "B' ∈ carrier_mat n n"
by (metis B inv_B'B inv_BB' carrier_matD(1) carrier_matD(2) carrier_mat_triv
index_mult_mat(3) index_one_mat(3) inverts_mat_def)
have "B * A * B = B" using A AB B by auto
hence "B * A * (B * B') = B * B'"
by (smt A AB B B'_carrier assoc_mult_mat carrier_matD(1) inv_BB' inverts_mat_def one_carrier_mat)
thus ?thesis
by (metis A B carrier_matD(1) carrier_matD(2) index_mult_mat(3) inv_BB'
inverts_mat_def right_mult_one_mat')
qed
context comm_ring_1
begin
lemma col_submatrix_UNIV:
assumes "j < card {i. i < dim_col A ∧ i ∈ J}"
shows "col (submatrix A UNIV J) j = col A (pick J j)"
proof (rule eq_vecI)
show dim_eq:"dim_vec (col (submatrix A UNIV J) j) = dim_vec (col A (pick J j))"
by (simp add: dim_submatrix(1))
fix i assume "i < dim_vec (col A (pick J j))"
show "col (submatrix A UNIV J) j $v i = col A (pick J j) $v i"
by (smt Collect_cong assms col_def dim_col dim_eq dim_submatrix(1)
eq_vecI index_vec pick_UNIV submatrix_index)
qed
lemma submatrix_split2: "submatrix A I J = submatrix (submatrix A I UNIV) UNIV J" (is "?lhs = ?rhs")
proof (rule eq_matI)
show dr: "dim_row ?lhs = dim_row ?rhs"
by (simp add: dim_submatrix(1))
show dc: "dim_col ?lhs = dim_col ?rhs"
by (simp add: dim_submatrix(2))
fix i j assume i: "i < dim_row ?rhs"
and j: "j < dim_col ?rhs"
have "?rhs $$ (i, j) = (submatrix A I UNIV) $$ (pick UNIV i, pick J j)"
proof (rule submatrix_index)
show "i < card {i. i < dim_row (submatrix A I UNIV) ∧ i ∈ UNIV}"
by (metis (full_types) dim_submatrix(1) i)
show "j < card {j. j < dim_col (submatrix A I UNIV) ∧ j ∈ J}"
by (metis (full_types) dim_submatrix(2) j)
qed
also have "... = A $$ (pick I (pick UNIV i), pick UNIV (pick J j))"
proof (rule submatrix_index)
show "pick UNIV i < card {i. i < dim_row A ∧ i ∈ I}"
by (metis (full_types) dr dim_submatrix(1) i pick_UNIV)
show "pick J j < card {j. j < dim_col A ∧ j ∈ UNIV}"
by (metis (full_types) dim_submatrix(2) j pick_le)
qed
also have "... = ?lhs $$ (i,j)"
proof (unfold pick_UNIV, rule submatrix_index[symmetric])
show "i < card {i. i < dim_row A ∧ i ∈ I}"
by (metis (full_types) dim_submatrix(1) dr i)
show "j < card {j. j < dim_col A ∧ j ∈ J}"
by (metis (full_types) dim_submatrix(2) dc j)
qed
finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" ..
qed
lemma submatrix_mult:
"submatrix (A*B) I J = submatrix A I UNIV * submatrix B UNIV J" (is "?lhs = ?rhs")
proof (rule eq_matI)
show "dim_row ?lhs = dim_row ?rhs" unfolding submatrix_def by auto
show "dim_col ?lhs = dim_col ?rhs" unfolding submatrix_def by auto
fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs"
have i1: "i < card {i. i < dim_row (A * B) ∧ i ∈ I}"
by (metis (full_types) dim_submatrix(1) i index_mult_mat(2))
have j1: "j < card {j. j < dim_col (A * B) ∧ j ∈ J}"
by (metis dim_submatrix(2) index_mult_mat(3) j)
have pi: "pick I i < dim_row A" using i1 pick_le by auto
have pj: "pick J j < dim_col B" using j1 pick_le by auto
have row_rw: "Matrix.row (submatrix A I UNIV) i = Matrix.row A (pick I i)"
using i1 row_submatrix_UNIV by auto
have col_rw: "col (submatrix B UNIV J) j = col B (pick J j)" using j1 col_submatrix_UNIV by auto
have "?lhs $$ (i,j) = (A*B) $$ (pick I i, pick J j)" by (rule submatrix_index[OF i1 j1])
also have "... = Matrix.row A (pick I i) ∙ col B (pick J j)" by (rule index_mult_mat(1)[OF pi pj])
also have "... = Matrix.row (submatrix A I UNIV) i ∙ col (submatrix B UNIV J) j"
using row_rw col_rw by simp
also have "... = (?rhs) $$ (i,j)" by (rule index_mult_mat[symmetric], insert i j, auto)
finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .
qed
lemma det_singleton:
assumes A: "A ∈ carrier_mat 1 1"
shows "det A = A $$ (0,0)"
using A unfolding carrier_mat_def Determinant.det_def by auto
lemma submatrix_singleton_index:
assumes A: "A ∈ carrier_mat n m"
and an: "a < n" and bm: "b < m"
shows "submatrix A {a} {b} $$ (0,0) = A $$ (a,b)"
proof -
have a: "{i. i = a ∧ i < dim_row A} = {a}" using an A unfolding carrier_mat_def by auto
have b: "{i. i = b ∧ i < dim_col A} = {b}" using bm A unfolding carrier_mat_def by auto
have "submatrix A {a} {b} $$ (0,0) = A $$ (pick {a} 0,pick {b} 0)"
by (rule submatrix_index, insert a b, auto)
moreover have "pick {a} 0 = a" by (auto, metis (full_types) LeastI)
moreover have "pick {b} 0 = b" by (auto, metis (full_types) LeastI)
ultimately show ?thesis by simp
qed
end
lemma det_not_inj_on:
assumes not_inj_on: "¬ inj_on f {0..<n}"
shows "det (mat⇩r n n (λi. Matrix.row B (f i))) = 0"
proof -
obtain i j where i: "i<n" and j: "j<n" and fi_fj: "f i = f j" and ij: "i≠j"
using not_inj_on unfolding inj_on_def by auto
show ?thesis
proof (rule det_identical_rows[OF _ ij i j])
let ?B="(mat⇩r n n (λi. row B (f i)))"
show "row ?B i = row ?B j"
proof (rule eq_vecI, auto)
fix ia assume ia: "ia < n"
have "row ?B i $ ia = ?B $$ (i, ia)" by (rule index_row(1), insert i ia, auto)
also have "... = ?B $$ (j, ia)" by (simp add: fi_fj i ia j)
also have "... = row ?B j $ ia" by (rule index_row(1)[symmetric], insert j ia, auto)
finally show "row ?B i $ ia = row (mat⇩r n n (λi. row B (f i))) j $ ia" by simp
qed
show "mat⇩r n n (λi. Matrix.row B (f i)) ∈ carrier_mat n n" by auto
qed
qed
lemma mat_row_transpose: "(mat⇩r nr nc f)⇧T = mat nc nr (λ(i,j). vec_index (f j) i)"
by (rule eq_matI, auto)
lemma obtain_inverse_matrix:
assumes A: "A ∈ carrier_mat n n" and i: "invertible_mat A"
obtains B where "inverts_mat A B" and "inverts_mat B A" and "B ∈ carrier_mat n n"
proof -
have "(∃B. inverts_mat A B ∧ inverts_mat B A)" using i unfolding invertible_mat_def by auto
from this obtain B where AB: "inverts_mat A B" and BA: "inverts_mat B A" by auto
moreover have "B ∈ carrier_mat n n" using A AB BA unfolding carrier_mat_def inverts_mat_def
by (auto, metis index_mult_mat(3) index_one_mat(3))+
ultimately show ?thesis using that by blast
qed
lemma invertible_mat_smult_mat:
fixes A :: "'a::comm_ring_1 mat"
assumes inv_A: "invertible_mat A" and k: "k dvd 1"
shows "invertible_mat (k ⋅⇩m A)"
proof -
obtain n where A: "A ∈ carrier_mat n n" using inv_A unfolding invertible_mat_def by auto
have det_dvd_1: "Determinant.det A dvd 1" using inv_A invertible_iff_is_unit_JNF[OF A] by auto
have "Determinant.det (k ⋅⇩m A) = k ^ dim_col A * Determinant.det A" by simp
also have "... dvd 1" by (rule unit_prod, insert k det_dvd_1 dvd_power_same, force+)
finally show ?thesis using invertible_iff_is_unit_JNF by (metis A smult_carrier_mat)
qed
lemma invertible_mat_one[simp]: "invertible_mat (1⇩m n)"
unfolding invertible_mat_def using inverts_mat_def by fastforce
lemma four_block_mat_dim0:
assumes A: "A ∈ carrier_mat n n"
and B: "B ∈ carrier_mat n 0"
and C: "C ∈ carrier_mat 0 n"
and D: "D ∈ carrier_mat 0 0"
shows "four_block_mat A B C D = A"
unfolding four_block_mat_def using assms by auto
lemma det_four_block_mat_lower_right_id:
assumes A: "A ∈ carrier_mat m m"
and B: "B = 0⇩m m (n-m)"
and C: "C = 0⇩m (n-m) m"
and D: "D = 1⇩m (n-m)"
and "n>m"
shows "Determinant.det (four_block_mat A B C D) = Determinant.det A"
using assms
proof (induct n arbitrary: A B C D)
case 0
then show ?case by auto
next
case (Suc n)
let ?block = "(four_block_mat A B C D)"
let ?B = "Matrix.mat m (n-m) (λ(i,j). 0)"
let ?C = "Matrix.mat (n-m) m (λ(i,j). 0)"
let ?D = "1⇩m (n-m)"
have mat_eq: "(mat_delete ?block n n) = four_block_mat A ?B ?C ?D" (is "?lhs = ?rhs")
proof (rule eq_matI)
fix i j assume i: "i < dim_row (four_block_mat A ?B ?C ?D)"
and j: "j < dim_col (four_block_mat A ?B ?C ?D)"
let ?f = " (if i < dim_row A then if j < dim_col A then A $$ (i, j) else B $$ (i, j - dim_col A)
else if j < dim_col A then C $$ (i - dim_row A, j) else D $$ (i - dim_row A, j - dim_col A))"
let ?g = "(if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?B $$ (i, j - dim_col A)
else if j < dim_col A then ?C $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))"
have "(mat_delete ?block n n) $$ (i,j) = ?block $$ (i,j)"
using i j Suc.prems unfolding mat_delete_def by auto
also have "... = ?f"
by (rule index_mat_four_block, insert Suc.prems i j, auto)
also have "... = ?g" using i j Suc.prems by auto
also have "... = four_block_mat A ?B ?C ?D $$ (i,j)"
by (rule index_mat_four_block[symmetric], insert Suc.prems i j, auto)
finally show "?lhs $$ (i,j) = ?rhs $$ (i,j)" .
qed (insert Suc.prems, auto)
have nn_1: "?block $$ (n, n) = 1" using Suc.prems by auto
have rw0: "(∑i<n. ?block $$ (i,n) * Determinant.cofactor ?block i n) = 0"
proof (rule sum.neutral, rule)
fix x assume x: "x ∈ {..<n}"
have block_index: "?block $$ (x,n) = (if x < dim_row A then if n < dim_col A then A $$ (x, n)
else B $$ (x, n - dim_col A) else if n < dim_col A then C $$ (x - dim_row A, n)
else D $$ (x - dim_row A, n - dim_col A))"
by (rule index_mat_four_block, insert Suc.prems x, auto)
have "four_block_mat A B C D $$ (x,n) = 0" using x Suc.prems by auto
thus "four_block_mat A B C D $$ (x, n) * Determinant.cofactor (four_block_mat A B C D) x n = 0"
by simp
qed
have "Determinant.det ?block = (∑i<Suc n. ?block $$ (i, n) * Determinant.cofactor ?block i n)"
by (rule laplace_expansion_column, insert Suc.prems, auto)
also have "... = ?block $$ (n, n) * Determinant.cofactor ?block n n
+ (∑i<n. ?block $$ (i,n) * Determinant.cofactor ?block i n)"
by simp
also have "... = ?block $$ (n, n) * Determinant.cofactor ?block n n" using rw0 by auto
also have "... = Determinant.cofactor ?block n n" using nn_1 by simp
also have "... = Determinant.det (mat_delete ?block n n)" unfolding cofactor_def by auto
also have "... = Determinant.det (four_block_mat A ?B ?C ?D)" using mat_eq by simp
also have "... = Determinant.det A" (is "Determinant.det ?lhs = Determinant.det ?rhs")
proof (cases "n = m")
case True
have "?lhs = ?rhs" by (rule four_block_mat_dim0, insert Suc.prems True, auto)
then show ?thesis by simp
next
case False
show ?thesis by (rule Suc.hyps, insert Suc.prems False, auto)
qed
finally show ?case .
qed
lemma mult_eq_first_row:
assumes A: "A ∈ carrier_mat 1 n"
and B: "B ∈ carrier_mat m n"
and m0: "m ≠ 0"
and r: "Matrix.row A 0 = Matrix.row B 0"
shows "Matrix.row (A * V) 0 = Matrix.row (B * V) 0"
proof (rule eq_vecI)
show "dim_vec (Matrix.row (A * V) 0) = dim_vec (Matrix.row (B * V) 0)" using A B r by auto
fix i assume i: "i < dim_vec (Matrix.row (B * V) 0)"
have "Matrix.row (A * V) 0 $v i = (A * V) $$ (0,i)" by (rule index_row, insert i A, auto)
also have "... = Matrix.row A 0 ∙ col V i" by (rule index_mult_mat, insert A i, auto)
also have "... = Matrix.row B 0 ∙ col V i" using r by auto
also have "... = (B * V) $$ (0,i)" by (rule index_mult_mat[symmetric], insert m0 B i, auto)
also have "... = Matrix.row (B * V) 0 $v i" by (rule index_row[symmetric], insert i B m0, auto)
finally show "Matrix.row (A * V) 0 $v i = Matrix.row (B * V) 0 $v i" .
qed
lemma smult_mat_mat_one_element:
assumes A: "A ∈ carrier_mat 1 1" and B: "B ∈ carrier_mat 1 n"
shows "A * B = A $$ (0,0) ⋅⇩m B"
proof (rule eq_matI)
fix i j assume i: "i < dim_row (A $$ (0, 0) ⋅⇩m B)" and j: "j < dim_col (A $$ (0, 0) ⋅⇩m B)"
have i0: "i = 0" using A B i by auto
have "(A * B) $$ (i, j) = Matrix.row A i ∙ col B j"
by (rule index_mult_mat, insert i j A B, auto)
also have "... = Matrix.row A i $v 0 * col B j $v 0" unfolding scalar_prod_def using B by auto
also have "... = A$$(i,i) * B$$(i,j)" using A i i0 j by auto
also have "... = (A $$ (i, i) ⋅⇩m B) $$ (i, j)"
unfolding i by (rule index_smult_mat[symmetric], insert i j B, auto)
finally show "(A * B) $$ (i, j) = (A $$ (0, 0) ⋅⇩m B) $$ (i, j)" using i0 by simp
qed (insert A B, auto)
lemma determinant_one_element:
assumes A: "A ∈ carrier_mat 1 1" shows "Determinant.det A = A $$ (0,0)"
proof -
have "Determinant.det A = prod_list (diag_mat A)"
by (rule det_upper_triangular[OF _ A], insert A, unfold upper_triangular_def, auto)
also have "... = A $$ (0,0)" using A unfolding diag_mat_def by auto
finally show ?thesis .
qed
lemma invertible_mat_transpose:
assumes inv_A: "invertible_mat (A::'a::comm_ring_1 mat)"
shows "invertible_mat A⇧T"
proof -
obtain n where A: "A ∈ carrier_mat n n"
using inv_A unfolding invertible_mat_def square_mat.simps by auto
hence At: "A⇧T ∈ carrier_mat n n" by simp
have "Determinant.det A⇧T = Determinant.det A"
by (metis Determinant.det_def Determinant.det_transpose carrier_matI
index_transpose_mat(2) index_transpose_mat(3))
also have "... dvd 1" using invertible_iff_is_unit_JNF[OF A] inv_A by simp
finally show ?thesis using invertible_iff_is_unit_JNF[OF At] by auto
qed
lemma dvd_elements_mult_matrix_left:
assumes A: "(A::'a::comm_ring_1 mat) ∈ carrier_mat m n"
and P: "P ∈ carrier_mat m m"
and x: "(∀i j. i<m ∧ j<n ⟶ x dvd A$$(i,j))"
shows "(∀i j. i<m ∧ j<n ⟶ x dvd (P*A)$$(i,j))"
proof -
have "x dvd (P * A) $$ (i, j)" if i: "i < m" and j: "j < n" for i j
proof -
have "(P * A) $$ (i, j) = (∑ia = 0..<m. Matrix.row P i $v ia * col A j $v ia)"
unfolding times_mat_def scalar_prod_def using A P j i by auto
also have "... = (∑ia = 0..<m. Matrix.row P i $v ia * A $$ (ia,j))"
by (rule sum.cong, insert A j, auto)
also have "x dvd ..." using x by (meson atLeastLessThan_iff dvd_mult dvd_sum j)
finally show ?thesis .
qed
thus ?thesis by auto
qed
lemma dvd_elements_mult_matrix_right:
assumes A: "(A::'a::comm_ring_1 mat) ∈ carrier_mat m n"
and Q: "Q ∈ carrier_mat n n"
and x: "(∀i j. i<m ∧ j<n ⟶ x dvd A$$(i,j))"
shows "(∀i j. i<m ∧ j<n ⟶ x dvd (A*Q)$$(i,j))"
proof -
have "x dvd (A*Q) $$ (i, j)" if i: "i < m" and j: "j < n" for i j
proof -
have "(A*Q) $$ (i, j) = (∑ia = 0..<n. Matrix.row A i $v ia * col Q j $v ia)"
unfolding times_mat_def scalar_prod_def using A Q j i by auto
also have "... = (∑ia = 0..<n. A $$ (i, ia) * col Q j $v ia)"
by (rule sum.cong, insert A Q i, auto)
also have "x dvd ..." using x
by (meson atLeastLessThan_iff dvd_mult2 dvd_sum i)
finally show ?thesis .
qed
thus ?thesis by auto
qed
lemma dvd_elements_mult_matrix_left_right:
assumes A: "(A::'a::comm_ring_1 mat) ∈ carrier_mat m n"
and P: "P ∈ carrier_mat m m"
and Q: "Q ∈ carrier_mat n n"
and x: "(∀i j. i<m ∧ j<n ⟶ x dvd A$$(i,j))"
shows "(∀i j. i<m ∧ j<n ⟶ x dvd (P*A*Q)$$(i,j))"
using dvd_elements_mult_matrix_left[OF A P x]
by (meson P A Q dvd_elements_mult_matrix_right mult_carrier_mat)
definition append_cols :: "'a :: zero mat ⇒ 'a mat ⇒ 'a mat" (infixr "@⇩c" 65)where
"A @⇩c B = four_block_mat A B (0⇩m 0 (dim_col A)) (0⇩m 0 (dim_col B))"
lemma append_cols_carrier[simp,intro]:
"A ∈ carrier_mat n a ⟹ B ∈ carrier_mat n b ⟹ (A @⇩c B) ∈ carrier_mat n (a+b)"
unfolding append_cols_def by auto
lemma append_cols_mult_left:
assumes A: "A ∈ carrier_mat n a"
and B: "B ∈ carrier_mat n b"
and P: "P ∈ carrier_mat n n"
shows "P * (A @⇩c B) = (P*A) @⇩c (P*B)"
proof -
let ?P = "four_block_mat P (0⇩m n 0) (0⇩m 0 n) (0⇩m 0 0)"
have "P = ?P" by (rule eq_matI, auto)
hence "P * (A @⇩c B) = ?P * (A @⇩c B)" by simp
also have "?P * (A @⇩c B) = four_block_mat (P * A + 0⇩m n 0 * 0⇩m 0 (dim_col A))
(P * B + 0⇩m n 0 * 0⇩m 0 (dim_col B)) (0⇩m 0 n * A + 0⇩m 0 0 * 0⇩m 0 (dim_col A))
(0⇩m 0 n * B + 0⇩m 0 0 * 0⇩m 0 (dim_col B))" unfolding append_cols_def
by (rule mult_four_block_mat, insert A B P, auto)
also have "... = four_block_mat (P * A) (P * B) (0⇩m 0 (dim_col (P*A))) (0⇩m 0 (dim_col (P*B)))"
by (rule cong_four_block_mat, insert P, auto)
also have "... = (P*A) @⇩c (P*B)" unfolding append_cols_def by auto
finally show ?thesis .
qed
lemma append_cols_mult_right_id:
assumes A: "(A::'a::semiring_1 mat) ∈ carrier_mat n 1"
and B: "B ∈ carrier_mat n (m-1)"
and C: "C = four_block_mat (1⇩m 1) (0⇩m 1 (m - 1)) (0⇩m (m - 1) 1) D"
and D: "D ∈ carrier_mat (m-1) (m-1)"
shows "(A @⇩c B) * C = A @⇩c (B * D)"
proof -
let ?C = "four_block_mat (1⇩m 1) (0⇩m 1 (m - 1)) (0⇩m (m - 1) 1) D"
have "(A @⇩c B) * C = (A @⇩c B) * ?C" unfolding C by auto
also have "... = four_block_mat A B (0⇩m 0 (dim_col A)) (0⇩m 0 (dim_col B)) * ?C"
unfolding append_cols_def by auto
also have "... = four_block_mat (A * 1⇩m 1 + B * 0⇩m (m - 1) 1) (A * 0⇩m 1 (m - 1) + B * D)
(0⇩m 0 (dim_col A) * 1⇩m 1 + 0⇩m 0 (dim_col B) * 0⇩m (m - 1) 1)
(0⇩m 0 (dim_col A) * 0⇩m 1 (m - 1) + 0⇩m 0 (dim_col B) * D)"
by (rule mult_four_block_mat, insert assms, auto)
also have "... = four_block_mat A (B * D) (0⇩m 0 (dim_col A)) (0⇩m 0 (dim_col (B*D)))"
by (rule cong_four_block_mat, insert assms, auto)
also have "... = A @⇩c (B * D)" unfolding append_cols_def by auto
finally show ?thesis .
qed
lemma append_cols_mult_right_id2:
assumes A: "(A::'a::semiring_1 mat) ∈ carrier_mat n a"
and B: "B ∈ carrier_mat n b"
and C: "C = four_block_mat D (0⇩m a b) (0⇩m b a) (1⇩m b)"
and D: "D ∈ carrier_mat a a"
shows "(A @⇩c B) * C = (A * D) @⇩c B"
proof -
let ?C = "four_block_mat D (0⇩m a b) (0⇩m b a) (1⇩m b)"
have "(A @⇩c B) * C = (A @⇩c B) * ?C" unfolding C by auto
also have "... = four_block_mat A B (0⇩m 0 a) (0⇩m 0 b) * ?C"
unfolding append_cols_def using A B by auto
also have "... = four_block_mat (A * D + B * 0⇩m b a) (A * 0⇩m a b + B * 1⇩m b)
(0⇩m 0 a * D + 0⇩m 0 b * 0⇩m b a) (0⇩m 0 a * 0⇩m a b + 0⇩m 0 b * 1⇩m b)"
by (rule mult_four_block_mat, insert A B C D, auto)
also have "... = four_block_mat (A * D) B (0⇩m 0 (dim_col (A*D))) (0⇩m 0 (dim_col B))"
by (rule cong_four_block_mat, insert assms, auto)
also have "... = (A * D) @⇩c B" unfolding append_cols_def by auto
finally show ?thesis .
qed
lemma append_cols_nth:
assumes A: "A ∈ carrier_mat n a"
and B: "B ∈ carrier_mat n b"
and i: "i<n" and j: "j < a + b"
shows "(A @⇩c B) $$ (i, j) = (if j < dim_col A then A $$(i,j) else B$$(i,j-a))" (is "?lhs = ?rhs")
proof -
let ?C = "(0⇩m 0 (dim_col A))"
let ?D = "(0⇩m 0 (dim_col B))"
have i2: "i < dim_row A + dim_row ?D" using i A by auto
have j2: "j < dim_col A + dim_col (0⇩m 0 (dim_col B))" using j B A by auto
have "(A @⇩c B) $$ (i, j) = four_block_mat A B ?C ?D $$ (i, j)"
unfolding append_cols_def by auto
also have "... = (if i < dim_row A then if j < dim_col A then A $$ (i, j)
else B $$ (i, j - dim_col A) else if j < dim_col A then ?C $$ (i - dim_row A, j)
else 0⇩m 0 (dim_col B) $$ (i - dim_row A, j - dim_col A))"
by (rule index_mat_four_block(1)[OF i2 j2])
also have "... = ?rhs" using i A by auto
finally show ?thesis .
qed
lemma append_cols_split:
assumes d: "dim_col A > 0"
shows "A = mat_of_cols (dim_row A) [col A 0] @⇩c
mat_of_cols (dim_row A) (map (col A) [1..<dim_col A])" (is "?lhs = ?A1 @⇩c ?A2")
proof (rule eq_matI)
fix i j assume i: "i < dim_row (?A1 @⇩c ?A2)" and j: "j < dim_col (?A1 @⇩c ?A2)"
have "(?A1 @⇩c ?A2) $$ (i, j) = (if j < dim_col ?A1 then ?A1 $$(i,j) else ?A2$$(i,j-(dim_col ?A1)))"
by (rule append_cols_nth, insert i j, auto simp add: append_cols_def)
also have "... = A $$ (i,j)"
proof (cases "j< dim_col ?A1")
case True
then show ?thesis
by (metis One_nat_def Suc_eq_plus1 add.right_neutral append_cols_def col_def i
index_mat_four_block(2) index_vec index_zero_mat(2) less_one list.size(3) list.size(4)
mat_of_cols_Cons_index_0 mat_of_cols_carrier(2) mat_of_cols_carrier(3))
next
case False
then show ?thesis
by (metis (no_types, lifting) Suc_eq_plus1 Suc_less_eq Suc_pred add_diff_cancel_right' append_cols_def
diff_zero i index_col index_mat_four_block(2) index_mat_four_block(3) index_zero_mat(2)
index_zero_mat(3) j length_map length_upt linordered_semidom_class.add_diff_inverse list.size(3)
list.size(4) mat_of_cols_carrier(2) mat_of_cols_carrier(3) mat_of_cols_index nth_map_upt
plus_1_eq_Suc upt_0)
qed
finally show "A $$ (i, j) = (?A1 @⇩c ?A2) $$ (i, j)" ..
qed (auto simp add: append_cols_def d)
lemma append_rows_nth:
assumes A: "A ∈ carrier_mat a n"
and B: "B ∈ carrier_mat b n"
and i: "i<a+b" and j: "j < n"
shows "(A @⇩r B) $$ (i, j) = (if i < dim_row A then A $$(i,j) else B$$(i-a,j))" (is "?lhs = ?rhs")
proof -
let ?C = "(0⇩m (dim_row A) 0)"
let ?D = "(0⇩m (dim_row B) 0)"
have i2: "i < dim_row A + dim_row ?D" using i j A B by auto
have j2: "j < dim_col A + dim_col ?D" using i j A B by auto
have "(A @⇩r B) $$ (i, j) = four_block_mat A ?C B ?D $$ (i, j)"
unfolding append_rows_def by auto
also have "... = (if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?C $$ (i, j - dim_col A)
else if j < dim_col A then B $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))"
by (rule index_mat_four_block(1)[OF i2 j2])
also have "... = ?rhs" using i A j B by auto
finally show ?thesis .
qed
lemma append_rows_split:
assumes k: "k≤dim_row A"
shows "A = (mat_of_rows (dim_col A) [Matrix.row A i. i ← [0..<k]]) @⇩r
(mat_of_rows (dim_col A) [Matrix.row A i. i ← [k..<dim_row A]])" (is "?lhs = ?A1 @⇩r ?A2")
proof (rule eq_matI)
have "(?A1 @⇩r ?A2) ∈ carrier_mat (k + (dim_row A-k)) (dim_col A)"
by (rule carrier_append_rows, insert k, auto)
hence A1_A2: "(?A1 @⇩r ?A2) ∈ carrier_mat (dim_row A) (dim_col A)" using k by simp
thus "dim_row A = dim_row (?A1 @⇩r ?A2)" and "dim_col A = dim_col (?A1 @⇩r ?A2)" by auto
fix i j assume i: "i < dim_row (?A1 @⇩r ?A2)" and j: "j < dim_col (?A1 @⇩r ?A2)"
have "(?A1 @⇩r ?A2) $$ (i, j) = (if i < dim_row ?A1 then ?A1 $$(i,j) else ?A2$$(i-(dim_row ?A1),j))"
by (rule append_rows_nth, insert k i j, auto simp add: append_rows_def)
also have "... = A $$ (i,j)"
proof (cases "i<dim_row ?A1")
case True
then show ?thesis
by (metis (no_types, lifting) Matrix.row_def add.left_neutral add.right_neutral append_rows_def
index_mat(1) index_mat_four_block(3) index_vec index_zero_mat(3) j length_map length_upt
mat_of_rows_carrier(2,3) mat_of_rows_def nth_map_upt prod.simps(2))
next
case False
let ?xs = "(map (Matrix.row A) [k..<dim_row A])"
have dim_row_A1: "dim_row ?A1 = k" by auto
have "?A2 $$ (i-k,j) = ?xs ! (i-k) $v j"
by (rule mat_of_rows_index, insert i k False A1_A2 j, auto)
also have "... = A $$ (i,j)" using A1_A2 False i j by auto
finally show ?thesis using A1_A2 False i j by auto
qed
finally show " A $$ (i, j) = (?A1 @⇩r ?A2) $$ (i,j)" by simp
qed
lemma transpose_mat_append_rows:
assumes A: "A ∈ carrier_mat a n" and B: "B ∈ carrier_mat b n"
shows "(A @⇩r B)⇧T = A⇧T @⇩c B⇧T"
by (smt append_cols_def append_rows_def A B carrier_matD(1) index_transpose_mat(3)
transpose_four_block_mat zero_carrier_mat zero_transpose_mat)
lemma transpose_mat_append_cols:
assumes A: "A ∈ carrier_mat n a" and B: "B ∈ carrier_mat n b"
shows "(A @⇩c B)⇧T = A⇧T @⇩r B⇧T"
by (metis Matrix.transpose_transpose A B carrier_matD(1) carrier_mat_triv
index_transpose_mat(3) transpose_mat_append_rows)
lemma append_rows_mult_right:
assumes A: "(A::'a::comm_semiring_1 mat) ∈ carrier_mat a n" and B: "B ∈ carrier_mat b n"
and Q: "Q∈ carrier_mat n n"
shows "(A @⇩r B) * Q = (A * Q) @⇩r (B*Q)"
proof -
have "transpose_mat ((A @⇩r B) * Q) = Q⇧T * (A @⇩r B)⇧T"
by (rule transpose_mult, insert A B Q, auto)
also have "... = Q⇧T * (A⇧T @⇩c B⇧T)" using transpose_mat_append_rows assms by metis
also have "... = Q⇧T * A⇧T @⇩c Q⇧T * B⇧T"
using append_cols_mult_left assms by (metis transpose_carrier_mat)
also have "transpose_mat ... = (A * Q) @⇩r (B*Q)"
by (smt A B Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def Q
carrier_mat_triv index_mult_mat(2) index_transpose_mat(2) transpose_four_block_mat
zero_carrier_mat zero_transpose_mat)
finally show ?thesis by simp
qed
lemma append_rows_mult_left_id:
assumes A: "(A::'a::comm_semiring_1 mat) ∈ carrier_mat 1 n"
and B: "B ∈ carrier_mat (m-1) n"
and C: "C = four_block_mat (1⇩m 1) (0⇩m 1 (m - 1)) (0⇩m (m - 1) 1) D"
and D: "D ∈ carrier_mat (m-1) (m-1)"
shows "C * (A @⇩r B) = A @⇩r (D * B)"
proof -
have "transpose_mat (C * (A @⇩r B)) = (A @⇩r B)⇧T * C⇧T"
by (metis (no_types, lifting) B C D Matrix.transpose_mult append_rows_def A carrier_matD
carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2) one_carrier_mat)
also have "... = (A⇧T @⇩c B⇧T) * C⇧T" using transpose_mat_append_rows[OF A B] by auto
also have "... = A⇧T @⇩c (B⇧T * D⇧T)" by (rule append_cols_mult_right_id, insert A B C D, auto)
also have "transpose_mat ... = A @⇩r (D * B)"
by (smt B D Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def A
carrier_matD(2) carrier_mat_triv index_mult_mat(3) index_transpose_mat(3)
transpose_four_block_mat zero_carrier_mat zero_transpose_mat)
finally show ?thesis by auto
qed
lemma append_rows_mult_left_id2:
assumes A: "(A::'a::comm_semiring_1 mat) ∈ carrier_mat a n"
and B: "B ∈ carrier_mat b n"
and C: "C = four_block_mat D (0⇩m a b) (0⇩m b a) (1⇩m b)"
and D: "D ∈ carrier_mat a a"
shows "C * (A @⇩r B) = (D * A) @⇩r B"
proof -
have "(C * (A @⇩r B))⇧T = (A @⇩r B)⇧T * C⇧T" by (rule transpose_mult, insert assms, auto)
also have "... = (A⇧T @⇩c B⇧T) * C⇧T" by (metis A B transpose_mat_append_rows)
also have "... = (A⇧T * D⇧T @⇩c B⇧T)" by (rule append_cols_mult_right_id2, insert assms, auto)
also have "...⇧T = (D * A) @⇩r B"
by (metis A B D transpose_mult transpose_transpose mult_carrier_mat transpose_mat_append_rows)
finally show ?thesis by simp
qed
lemma four_block_mat_preserves_column:
assumes A: "(A::'a::semiring_1 mat) ∈ carrier_mat n m"
and B: "B = four_block_mat (1⇩m 1) (0⇩m 1 (m - 1)) (0⇩m (m - 1) 1) C"
and C: "C ∈ carrier_mat (m-1) (m-1)"
and i: "i<n" and m: "0<m"
shows "(A*B) $$ (i,0) = A $$ (i,0)"
proof -
let ?A1 = "mat_of_cols n [col A 0]"
let ?A2 = "mat_of_cols n (map (col A) [1..<dim_col A])"
have n2: "dim_row A = n" using A by auto
have "A = ?A1 @⇩c ?A2" by (rule append_cols_split[of A, unfolded n2], insert m A, auto)
hence "A * B = (?A1 @⇩c ?A2) * B" by simp
also have "... = ?A1 @⇩c (?A2 * C)" by (rule append_cols_mult_right_id[OF _ _ B C], insert A, auto)
also have "... $$ (i,0) = ?A1 $$ (i,0)" using append_cols_nth by (simp add: append_cols_def i)
also have "... = A $$ (i,0)"
by (metis A i carrier_matD(1) col_def index_vec mat_of_cols_Cons_index_0)
finally show ?thesis .
qed
definition "lower_triangular A = (∀i j. i < j ∧ i < dim_row A ∧ j < dim_col A ⟶ A $$ (i,j) = 0)"
lemma lower_triangular_index:
assumes "lower_triangular A" "i<j" "i < dim_row A" "j < dim_col A"
shows "A $$ (i,j) = 0"
using assms unfolding lower_triangular_def by auto
lemma commute_multiples_identity:
assumes A: "(A::'a::comm_ring_1 mat) ∈ carrier_mat n n"
shows "A * (k ⋅⇩m (1⇩m n)) = (k ⋅⇩m (1⇩m n)) * A"
proof -
have "(∑ia = 0..<n. A $$ (i, ia) * (k * (if ia = j then 1 else 0)))
= (∑ia = 0..<n. k * (if i = ia then 1 else 0) * A $$ (ia, j))" (is "?lhs=?rhs")
if i: "i<n" and j: "j<n" for i j
proof -
let ?f = "λia. A $$ (i, ia) * (k * (if ia = j then 1 else 0))"
let ?g = "λia. k * (if i = ia then 1 else 0) * A $$ (ia, j)"
have rw0: "(∑ia ∈ ({0..<n}-{j}). ?f ia) = 0" by (rule sum.neutral, auto)
have rw0': "(∑ia ∈ ({0..<n}-{i}). ?g ia) = 0" by (rule sum.neutral, auto)
have "?lhs = ?f j + (∑ia ∈ ({0..<n}-{j}). ?f ia)"
by (smt atLeast0LessThan finite_atLeastLessThan lessThan_iff sum.remove j)
also have "... = A $$ (i, j) * k" using rw0 by auto
also have "... = ?g i + (∑ia ∈ ({0..<n}-{i}). ?g ia)" using rw0' by auto
also have "... = ?rhs"
by (smt atLeast0LessThan finite_atLeastLessThan lessThan_iff sum.remove i)
finally show ?thesis .
qed
thus ?thesis using A
unfolding times_mat_def scalar_prod_def
by auto (rule eq_matI, auto, smt sum.cong)
qed
lemma det_2:
assumes A: "A ∈ carrier_mat 2 2"
shows "Determinant.det A = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)"
proof -
let ?A = "(Mod_Type_Connect.to_hma⇩m A)::'a^2^2"
have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?A"
unfolding Mod_Type_Connect.HMA_M_def using from_hma_to_hma⇩m A by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_I 0 0"
unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_0)
have [transfer_rule]: "Mod_Type_Connect.HMA_I 1 1"
unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_1)
have "Determinant.det A = Determinants.det ?A" by (transfer, simp)
also have "... = ?A $h 1 $h 1 * ?A $h 2 $h 2 - ?A $h 1 $h 2 * ?A $h 2 $h 1" unfolding det_2 by simp
also have "... = ?A $h 0 $h 0 * ?A $h 1 $h 1 - ?A $h 0 $h 1 * ?A $h 1 $h 0"
by (smt Groups.mult_ac(2) exhaust_2 semiring_norm(160))
also have "... = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)"
unfolding index_hma_def[symmetric] by (transfer, auto)
finally show ?thesis .
qed
lemma mat_diag_smult: "mat_diag n (λ x. (k::'a::comm_ring_1)) = (k ⋅⇩m 1⇩m n)"
proof -
have "mat_diag n (λ x. k) = mat_diag n (λ x. k * 1)" by auto
also have "... = mat_diag n (λ x. k) * mat_diag n (λ x. 1)" using mat_diag_diag
by (simp add: mat_diag_def)
also have "... = mat_diag n (λ x. k) * (1⇩m n)" by auto thm mat_diag_mult_left
also have "... = Matrix.mat n n (λ(i, j). k * (1⇩m n) $$ (i, j))" by (rule mat_diag_mult_left, auto)
also have "... = (k ⋅⇩m 1⇩m n)" unfolding smult_mat_def by auto
finally show ?thesis .
qed
lemma invertible_mat_four_block_mat_lower_right:
assumes A: "(A::'a::comm_ring_1 mat) ∈ carrier_mat n n" and inv_A: "invertible_mat A"
shows "invertible_mat (four_block_mat (1⇩m 1) (0⇩m 1 n) (0⇩m n 1) A)"
proof -
let ?I = "(four_block_mat (1⇩m 1) (0⇩m 1 n) (0⇩m n 1) A)"
have "Determinant.det ?I = Determinant.det (1⇩m 1) * Determinant.det A"
by (rule det_four_block_mat_lower_left_zero_col, insert assms, auto)
also have "... = Determinant.det A" by auto
finally have "Determinant.det ?I = Determinant.det A" .
thus ?thesis
by (metis (no_types, lifting) assms carrier_matD(1) carrier_matD(2) carrier_mat_triv
index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3)
invertible_iff_is_unit_JNF)
qed
lemma invertible_mat_four_block_mat_lower_right_id:
assumes A: "(A::'a::comm_ring_1 mat) ∈ carrier_mat m m" and B: "B = 0⇩m m (n-m)" and C: "C = 0⇩m (n-m) m"
and D: "D = 1⇩m (n-m)" and "n>m" and inv_A: "invertible_mat A"
shows "invertible_mat (four_block_mat A B C D)"
proof -
have "Determinant.det (four_block_mat A B C D) = Determinant.det A"
by (rule det_four_block_mat_lower_right_id, insert assms, auto)
thus ?thesis using inv_A
by (metis (no_types, lifting) assms(1) assms(4) carrier_matD(1) carrier_matD(2) carrier_mat_triv
index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3)
invertible_iff_is_unit_JNF)
qed
lemma split_block4_decreases_dim_row:
assumes E: "(A,B,C,D) = split_block E 1 1"
and E1: "dim_row E > 1" and E2: "dim_col E > 1"
shows "dim_row D < dim_row E"
proof -
have "D ∈ carrier_mat (1 + (dim_row E - 2)) (1 + (dim_col E - 2))"
by (rule split_block(4)[OF E[symmetric]], insert E1 E2, auto)
hence "D ∈ carrier_mat (dim_row E - 1) (dim_col E - 1)" using E1 E2 by auto
thus ?thesis using E1 by auto
qed
lemma inv_P'PAQQ':
assumes A: "A ∈ carrier_mat n n"
and P: "P ∈ carrier_mat n n"
and inv_P: "inverts_mat P' P"
and inv_Q: "inverts_mat Q Q'"
and Q: "Q ∈ carrier_mat n n"
and P': "P' ∈ carrier_mat n n"
and Q': "Q' ∈ carrier_mat n n"
shows "(P'*(P*A*Q)*Q') = A"
proof -
have "(P'*(P*A*Q)*Q') = (P'*(P*A*Q*Q'))"
by (smt P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv
index_mult_mat(2) index_mult_mat(3))
also have "... = ((P'*P)*A*(Q*Q'))"
by (smt A P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv
index_mult_mat(3) inv_Q inverts_mat_def right_mult_one_mat')
finally show ?thesis
by (metis P' Q A inv_P inv_Q carrier_matD(1) inverts_mat_def
left_mult_one_mat right_mult_one_mat)
qed
lemma
assumes "U ∈ carrier_mat 2 2" and "V ∈ carrier_mat 2 2" and "A = U * V"
shows mat_mult2_00: "A $$ (0,0) = U $$ (0,0)*V $$ (0,0) + U $$ (0,1)*V $$ (1,0)"
and mat_mult2_01: "A $$ (0,1) = U $$ (0,0)*V $$ (0,1) + U $$ (0,1)*V $$ (1,1)"
and mat_mult2_10: "A $$ (1,0) = U $$ (1,0)*V $$ (0,0) + U $$ (1,1)*V $$ (1,0)"
and mat_mult2_11: "A $$ (1,1) = U $$ (1,0)*V $$ (0,1) + U $$ (1,1)*V $$ (1,1)"
using assms unfolding times_mat_def Matrix.row_def col_def scalar_prod_def
using sum_two_rw by auto
subsection‹Lemmas about @{text "sorted lists"}, @{text "insort"} and @{text "pick"}›
lemma sorted_distinct_imp_sorted_wrt:
assumes "sorted xs" and "distinct xs"
shows "sorted_wrt (<) xs"
using assms
by (induct xs, insert le_neq_trans, auto)
lemma sorted_map_strict:
assumes "strict_mono_on g {0..<n}"
shows "sorted (map g [0..<n])"
using assms
by (induct n, auto simp add: sorted_append strict_mono_on_def less_imp_le)
lemma sorted_list_of_set_map_strict:
assumes "strict_mono_on g {0..<n}"
shows "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
using assms
proof (induct n)
case 0
then show ?case by auto
next
case (Suc n)
note sg = Suc.prems
have sg_n: "strict_mono_on g {0..<n}" using sg unfolding strict_mono_on_def by auto
have g_image_rw: "g ` {0..<Suc n} = insert (g n) (g ` {0..<n})"
by (simp add: set_upt_Suc)
have "sorted_list_of_set (g ` {0..<Suc n}) = sorted_list_of_set (insert (g n) (g ` {0..<n}))"
using g_image_rw by simp
also have "... = insort (g n) (sorted_list_of_set (g ` {0..<n}))"
proof (rule sorted_list_of_set.insert)
have "inj_on g {0..<Suc n}" using sg strict_mono_on_imp_inj_on by blast
thus "g n ∉ g ` {0..<n}" unfolding inj_on_def by fastforce
qed (simp)
also have "... = insort (g n) (map g [0..<n])"
using Suc.hyps sg unfolding strict_mono_on_def by auto
also have "... = map g [0..<Suc n]"
proof (simp, rule sorted_insort_is_snoc)
show "sorted (map g [0..<n])" by (rule sorted_map_strict[OF sg_n])
show "∀x∈set (map g [0..<n]). x ≤ g n" using sg unfolding strict_mono_on_def
by (simp add: less_imp_le)
qed
finally show ?case .
qed
lemma sorted_nth_strict_mono:
"sorted xs ⟹ distinct xs ⟹i < j ⟹ j < length xs ⟹ xs!i < xs!j"
by (simp add: less_le nth_eq_iff_index_eq sorted_iff_nth_mono_less)
lemma sorted_list_of_set_0_LEAST:
assumes finI: "finite I" and I: "I ≠ {}"
shows "sorted_list_of_set I ! 0 = (LEAST n. n∈I)"
proof (rule Least_equality[symmetric])
show "sorted_list_of_set I ! 0 ∈ I"
by (metis I Max_in finI gr_zeroI in_set_conv_nth not_less_zero set_sorted_list_of_set)
fix y assume "y ∈ I"
thus "sorted_list_of_set I ! 0 ≤ y"
by (metis eq_iff finI in_set_conv_nth neq0_conv sorted_iff_nth_mono_less
sorted_list_of_set(1) sorted_sorted_list_of_set)
qed
lemma sorted_list_of_set_eq_pick:
assumes i: "i < length (sorted_list_of_set I)"
shows "sorted_list_of_set I ! i = pick I i"
proof -
have finI: "finite I"
proof (rule ccontr)
assume "infinite I"
hence "length (sorted_list_of_set I) = 0" using sorted_list_of_set.infinite by auto
thus False using i by simp
qed
show ?thesis
using i
proof (induct i)
case 0
have I: "I ≠ {}" using "0.prems" sorted_list_of_set_empty by blast
show ?case unfolding pick.simps by (rule sorted_list_of_set_0_LEAST[OF finI I])
next
case (Suc i)
note x_less = Suc.prems
show ?case
proof (unfold pick.simps, rule Least_equality[symmetric], rule conjI)
show 1: "pick I i < sorted_list_of_set I ! Suc i"
by (metis Suc.hyps Suc.prems Suc_lessD distinct_sorted_list_of_set find_first_unique lessI
nat_less_le sorted_sorted_list_of_set sorted_sorted_wrt sorted_wrt_nth_less)
show "sorted_list_of_set I ! Suc i ∈ I"
using Suc.prems finI nth_mem set_sorted_list_of_set by blast
have rw: "sorted_list_of_set I ! i = pick I i"
using Suc.hyps Suc_lessD x_less by blast
have sorted_less: "sorted_list_of_set I ! i < sorted_list_of_set I ! Suc i"
by (simp add: 1 rw)
fix y assume y: "y ∈ I ∧ pick I i < y"
show "sorted_list_of_set I ! Suc i ≤ y"
by (smt antisym_conv finI in_set_conv_nth less_Suc_eq less_Suc_eq_le nat_neq_iff rw
sorted_iff_nth_mono_less sorted_list_of_set(1) sorted_sorted_list_of_set x_less y)
qed
qed
qed
text‹$b$ is the position where we add, $a$ the element to be added and $i$ the position
that is checked›
lemma insort_nth':
assumes "∀j<b. xs ! j < a" and "sorted xs" and "a ∉ set xs"
and "i < length xs + 1" and "i < b"
and "xs ≠ []" and "b < length xs"
shows "insort a xs ! i = xs ! i"
using assms
proof (induct xs arbitrary: a b i)
case Nil
then show ?case by auto
next
case (Cons x xs)
note less = Cons.prems(1)
note sorted = Cons.prems(2)
note a_notin = Cons.prems(3)
note i_length = Cons.prems(4)
note i_b = Cons.prems(5)
note b_length = Cons.prems(7)
show ?case
proof (cases "a ≤ x")
case True
have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp
also have "... = (x # xs) ! i"
using Cons.prems(1) Cons.prems(5) True by force
finally show ?thesis .
next
case False note x_less_a = False
have "insort a (x # xs) ! i = (x # insort a xs) ! i" using False by simp
also have "... = (x # xs) ! i"
proof (cases "i = 0")
case True
then show ?thesis by auto
next
case False
have "(x # insort a xs) ! i = (insort a xs) ! (i-1)"
by (simp add: False nth_Cons')
also have "... = xs ! (i-1)"
proof (rule Cons.hyps)
show "sorted xs" using sorted by simp
show "a ∉ set xs" using a_notin by simp
show "i - 1 < length xs + 1" using i_length False by auto
show "xs ≠ []" using i_b b_length by force
show "i - 1 < b - 1" by (simp add: False diff_less_mono i_b leI)
show "b - 1 < length xs" using b_length i_b by auto
show "∀j<b - 1. xs ! j < a" using less less_diff_conv by auto
qed
also have "... = (x # xs) ! i" by (simp add: False nth_Cons')
finally show ?thesis .
qed
finally show ?thesis .
qed
qed
lemma insort_nth:
assumes "sorted xs" and "a ∉ set xs"
and "i < index (insort a xs) a"
and "xs ≠ []"
shows "insort a xs ! i = xs ! i"
using assms
proof (induct xs arbitrary: a i)
case Nil
then show ?case by auto
next
case (Cons x xs)
note sorted = Cons.prems(1)
note a_notin = Cons.prems(2)
note i_index = Cons.prems(3)
show ?case
proof (cases "a ≤ x")
case True
have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp
also have "... = (x # xs) ! i"
using Cons.prems(1) Cons.prems(3) True by force
finally show ?thesis .
next
case False note x_less_a = False
show ?thesis
proof (cases "xs = []")
case True
have "x ≠ a" using False by auto
then show ?thesis using True i_index False by auto
next
case False note xs_not_empty = False
have "insort a (x # xs) ! i = (x # insort a xs) ! i" using x_less_a by simp
also have "... = (x # xs) ! i"
proof (cases "i = 0")
case True
then show ?thesis by auto
next
case False note i0 = False
have "(x # insort a xs) ! i = (insort a xs) ! (i-1)"
by (simp add: False nth_Cons')
also have "... = xs ! (i-1)"
proof (rule Cons.hyps[OF _ _ _ xs_not_empty])
show "sorted xs" using sorted by simp
show "a ∉ set xs" using a_notin by simp
have "index (insort a (x # xs)) a = index ((x # insort a xs)) a"
using x_less_a by auto
also have "... = index (insort a xs) a + 1"
unfolding index_Cons using x_less_a by simp
finally show "i - 1 < index (insort a xs) a" using False i_index by linarith
qed
also have "... = (x # xs) ! i" by (simp add: False nth_Cons')
finally show ?thesis .
qed
finally show ?thesis .
qed
qed
qed
lemma insort_nth2:
assumes "sorted xs" and "a ∉ set xs"
and "i < length xs" and "i ≥ index (insort a xs) a"
and "xs ≠ []"
shows "insort a xs ! (Suc i) = xs ! i"
using assms
proof (induct xs arbitrary: a i)
case Nil
then show ?case by auto
next
case (Cons x xs)
note sorted = Cons.prems(1)
note a_notin = Cons.prems(2)
note i_length = Cons.prems(3)
note index_i = Cons.prems(4)
show ?case
proof (cases "a ≤ x")
case True
have "insort a (x # xs) ! (Suc i) = (a # x # xs) ! (Suc i)" using True by simp
also have "... = (x # xs) ! i"
using Cons.prems(1) Cons.prems(5) True by force
finally show ?thesis .
next
case False note x_less_a = False
have "insort a (x # xs) ! (Suc i) = (x # insort a xs) ! (Suc i)" using False by simp
also have "... = (x # xs) ! i"
proof (cases "i = 0")
case True
then show ?thesis using index_i linear x_less_a by fastforce
next
case False note i0 = False
show ?thesis
proof -
have Suc_i: "Suc (i - 1) = i"
using i0 by auto
have "(x # insort a xs) ! (Suc i) = (insort a xs) ! i"
by (simp add: nth_Cons')
also have "... = (insort a xs) ! Suc (i - 1)" using Suc_i by simp
also have "... = xs ! (i - 1)"
proof (rule Cons.hyps)
show "sorted xs" using sorted by simp
show "a ∉ set xs" using a_notin by simp
show "i - 1 < length xs" using i_length using Suc_i by auto
thus "xs ≠ []" by auto
have "index (insort a (x # xs)) a = index ((x # insort a xs)) a" using x_less_a by simp
also have "... = index (insort a xs) a + 1" unfolding index_Cons using x_less_a by simp
finally show "index (insort a xs) a ≤ i - 1" using index_i i0 by auto
qed
also have "... = (x # xs) ! i" using Suc_i by auto
finally show ?thesis .
qed
qed
finally show ?thesis .
qed
qed
lemma pick_index:
assumes a: "a ∈ I" and a'_card: "a' < card I"
shows "(pick I a' = a) = (index (sorted_list_of_set I) a = a')"
proof -
have finI: "finite I" using a'_card card.infinite by force
have length_I: "length (sorted_list_of_set I) = card I"
by (metis a'_card card.infinite distinct_card distinct_sorted_list_of_set
not_less_zero set_sorted_list_of_set)
let ?i = "index (sorted_list_of_set I) a"
have "(sorted_list_of_set I) ! a' = pick I a'"
by (rule sorted_list_of_set_eq_pick, auto simp add: finI a'_card length_I)
moreover have "(sorted_list_of_set I) ! ?i = a"
by (rule nth_index, simp add: a finI)
ultimately show ?thesis
by (metis a'_card distinct_sorted_list_of_set index_nth_id length_I)
qed
end
Theory Cauchy_Binet
section ‹The Cauchy--Binet formula›
theory Cauchy_Binet
imports
Diagonal_To_Smith
SNF_Missing_Lemmas
begin
subsection ‹Previous missing results about @{text "pick"} and @{text "insert"}›
lemma pick_insert:
assumes a_notin_I: "a ∉ I" and i2: "i < card I"
and a_def: "pick (insert a I) a' = a"
and ia': "i < a'"
and a'_card: "a' < card I + 1"
shows "pick (insert a I) i = pick I i"
proof -
have finI: "finite I"
using i2
using card.infinite by force
have "pick (insert a I) i = sorted_list_of_set (insert a I) ! i"
proof (rule sorted_list_of_set_eq_pick[symmetric])
have "finite (insert a I)"
using card.infinite i2 by force
thus "i < length (sorted_list_of_set (insert a I))"
by (metis a_notin_I card_insert_disjoint distinct_card finite_insert
i2 less_Suc_eq sorted_list_of_set(1) sorted_list_of_set(3))
qed
also have "... = insort a (sorted_list_of_set I) ! i"
using sorted_list_of_set.insert
by (metis a_notin_I card.infinite i2 not_less0)
also have "... = (sorted_list_of_set I) ! i"
proof (rule insort_nth[OF])
show "sorted (sorted_list_of_set I)" by auto
show "a ∉ set (sorted_list_of_set I)" using a_notin_I
by (metis card.infinite i2 not_less_zero set_sorted_list_of_set)
have "index (sorted_list_of_set (insert a I)) a = a'"
using pick_index a_def
using a'_card a_notin_I finI by auto
hence "index (insort a (sorted_list_of_set I)) a = a'"
by (simp add: a_notin_I finI)
thus "i < index (insort a (sorted_list_of_set I)) a" using ia' by auto
show "sorted_list_of_set I ≠ []" using finI i2 by fastforce
qed
also have "... = pick I i"
proof (rule sorted_list_of_set_eq_pick)
have "finite I" using card.infinite i2 by fastforce
thus "i < length (sorted_list_of_set I)"
by (metis distinct_card distinct_sorted_list_of_set i2 set_sorted_list_of_set)
qed
finally show ?thesis .
qed
lemma pick_insert2:
assumes a_notin_I: "a ∉ I" and i2: "i < card I"
and a_def: "pick (insert a I) a' = a"
and ia': "i ≥ a'"
and a'_card: "a' < card I + 1"
shows "pick (insert a I) i < pick I i"
proof (cases "i = 0")
case True
then show ?thesis
by (auto, metis (mono_tags, lifting) DL_Missing_Sublist.pick.simps(1) Least_le a_def a_notin_I
dual_order.order_iff_strict i2 ia' insertCI le_zero_eq not_less_Least pick_in_set_le)
next
case False
hence i0: "i = Suc (i - 1)" using a'_card ia' by auto
have finI: "finite I"
using i2 card.infinite by force
have index_a'1: "index (sorted_list_of_set (insert a I)) a = a'"
using pick_index
using a'_card a_def a_notin_I finI by auto
hence index_a': "index (insort a (sorted_list_of_set I)) a = a'"
by (simp add: a_notin_I finI)
have i1_length: "i - 1 < length (sorted_list_of_set I)" using i2
by (metis distinct_card distinct_sorted_list_of_set finI
less_imp_diff_less set_sorted_list_of_set)
have 1: "pick (insert a I) i = sorted_list_of_set (insert a I) ! i"
proof (rule sorted_list_of_set_eq_pick[symmetric])
have "finite (insert a I)"
using card.infinite i2 by force
thus "i < length (sorted_list_of_set (insert a I))"
by (metis a_notin_I card_insert_disjoint distinct_card finite_insert
i2 less_Suc_eq sorted_list_of_set(1) sorted_list_of_set(3))
qed
also have 2: "... = insort a (sorted_list_of_set I) ! i"
using sorted_list_of_set.insert
by (metis a_notin_I card.infinite i2 not_less0)
also have "... = insort a (sorted_list_of_set I) ! Suc (i-1)" using i0 by auto
also have "... < pick I i"
proof (cases "i = a'")
case True
have "(sorted_list_of_set I) ! i > a"
by (smt "1" Suc_less_eq True a_def a_notin_I distinct_card distinct_sorted_list_of_set finI i2
ia' index_a' insort_nth2 length_insort lessI list.size(3) nat_less_le not_less_zero
pick_in_set_le set_sorted_list_of_set sorted_list_of_set(2) sorted_list_of_set.insert
sorted_list_of_set_eq_pick sorted_sorted_wrt sorted_wrt_nth_less)
moreover have "a = insort a (sorted_list_of_set I) ! i" using True 1 2 a_def by auto
ultimately show ?thesis using 1 2
by (metis distinct_card finI i0 i2 set_sorted_list_of_set
sorted_list_of_set(3) sorted_list_of_set_eq_pick)
next
case False
have "insort a (sorted_list_of_set I) ! Suc (i-1) = (sorted_list_of_set I) ! (i-1)"
by (rule insort_nth2, insert i1_length False ia' index_a', auto simp add: a_notin_I finI)
also have "... = pick I (i-1)"
by (rule sorted_list_of_set_eq_pick[OF i1_length])
also have "... < pick I i" using i0 i2 pick_mono_le by auto
finally show ?thesis .
qed
finally show ?thesis .
qed
lemma pick_insert3:
assumes a_notin_I: "a ∉ I" and i2: "i < card I"
and a_def: "pick (insert a I) a' = a"
and ia': "i ≥ a'"
and a'_card: "a' < card I + 1"
shows "pick (insert a I) (Suc i) = pick I i"
proof (cases "i = 0")
case True
have a_LEAST: "a < (LEAST aa. aa∈I)"
using True a_def a_notin_I i2 ia' pick_insert2 by fastforce
have Least_rw: "(LEAST aa. aa = a ∨ aa ∈ I) = a"
by (rule Least_equality, insert a_notin_I, auto,
metis a_LEAST le_less_trans nat_le_linear not_less_Least)
let ?P = "λaa. (aa = a ∨ aa ∈ I) ∧ (LEAST aa. aa = a ∨ aa ∈ I) < aa"
let ?Q = "λaa. aa ∈ I"
have "?P = ?Q" unfolding Least_rw fun_eq_iff
by (auto, metis a_LEAST le_less_trans not_le not_less_Least)
thus ?thesis using True by auto
next
case False
have finI: "finite I"
using i2 card.infinite by force
have index_a'1: "index (sorted_list_of_set (insert a I)) a = a'"
using pick_index
using a'_card a_def a_notin_I finI by auto
hence index_a': "index (insort a (sorted_list_of_set I)) a = a'"
by (simp add: a_notin_I finI)
have i1_length: "i < length (sorted_list_of_set I)" using i2
by (metis distinct_card distinct_sorted_list_of_set finI set_sorted_list_of_set)
have 1: "pick (insert a I) (Suc i) = sorted_list_of_set (insert a I) ! (Suc i)"
proof (rule sorted_list_of_set_eq_pick[symmetric])
have "finite (insert a I)"
using card.infinite i2 by force
thus "Suc i < length (sorted_list_of_set (insert a I))"
by (metis Suc_mono a_notin_I card_insert_disjoint distinct_card distinct_sorted_list_of_set
finI i2 set_sorted_list_of_set)
qed
also have 2: "... = insort a (sorted_list_of_set I) ! Suc i"
using sorted_list_of_set.insert
by (metis a_notin_I card.infinite i2 not_less0)
also have "... = pick I i"
proof (cases "i = a'")
case True
show ?thesis
by (metis True a_notin_I finI i1_length index_a' insort_nth2 le_refl list.size(3) not_less0
set_sorted_list_of_set sorted_list_of_set(2) sorted_list_of_set_eq_pick)
next
case False
have "insort a (sorted_list_of_set I) ! Suc i = (sorted_list_of_set I) ! i"
by (rule insort_nth2, insert i1_length False ia' index_a', auto simp add: a_notin_I finI)
also have "... = pick I i"
by (rule sorted_list_of_set_eq_pick[OF i1_length])
finally show ?thesis .
qed
finally show ?thesis .
qed
lemma pick_insert_index:
assumes Ik: "card I = k"
and a_notin_I: "a ∉ I"
and ik: "i < k"
and a_def: "pick (insert a I) a' = a"
and a'k: "a' < card I + 1"
shows "pick (insert a I) (insert_index a' i) = pick I i"
proof (cases "i<a'")
case True
have "pick (insert a I) i = pick I i"
by (rule pick_insert[OF a_notin_I _ a_def _ a'k], auto simp add: Ik ik True)
thus ?thesis using True unfolding insert_index_def by auto
next
case False note i_ge_a' = False
have fin_aI: "finite (insert a I)"
using Ik finite_insert ik by fastforce
let ?P = "λaa. (aa = a ∨ aa ∈ I) ∧ pick (insert a I) i < aa"
let ?Q = "λaa. aa ∈ I ∧ pick (insert a I) i < aa"
have "?P = ?Q" using a_notin_I unfolding fun_eq_iff
by (auto, metis False Ik a_def card.infinite card_insert_disjoint ik less_SucI
linorder_neqE_nat not_less_zero order.asym pick_mono_le)
hence "Least ?P = Least ?Q" by simp
also have "... = pick I i"
proof (rule Least_equality, rule conjI)
show "pick I i ∈ I"
by (simp add: Ik ik pick_in_set_le)
show "pick (insert a I) i < pick I i"
by (rule pick_insert2[OF a_notin_I _ a_def _ a'k], insert False, auto simp add: Ik ik)
fix y assume y: "y ∈ I ∧ pick (insert a I) i < y"
let ?xs = "sorted_list_of_set (insert a I)"
have "y ∈ set ?xs" using y by (metis fin_aI insertI2 set_sorted_list_of_set y)
from this obtain j where xs_j_y: "?xs ! j = y" and j: "j < length ?xs"
using in_set_conv_nth by metis
have ij: "i<j"
by (metis (no_types, lifting) Ik a_notin_I card.infinite card_insert_disjoint ik j less_SucI
linorder_neqE_nat not_less_zero order.asym pick_mono_le sorted_list_of_set_eq_pick xs_j_y y)
have "pick I i = pick (insert a I) (Suc i)"
by (rule pick_insert3[symmetric, OF a_notin_I _ a_def _ a'k], insert False Ik ik, auto)
also have "... ≤ pick (insert a I) j"
by (metis Ik Suc_lessI card.infinite distinct_card distinct_sorted_list_of_set eq_iff
finite_insert ij ik j less_imp_le_nat not_less_zero pick_mono_le set_sorted_list_of_set)
also have "... = ?xs ! j" by (rule sorted_list_of_set_eq_pick[symmetric, OF j])
also have "... = y" by (rule xs_j_y)
finally show "pick I i ≤ y" .
qed
finally show ?thesis unfolding insert_index_def using False by auto
qed
subsection‹Start of the proof›
definition "strict_from_inj n f = (λi. if i∈{0..<n} then (sorted_list_of_set (f`{0..<n})) ! i else i)"
lemma strict_strict_from_inj:
fixes f::"nat ⇒ nat"
assumes "inj_on f {0..<n}" shows "strict_mono_on (strict_from_inj n f) {0..<n}"
proof -
let ?I="f`{0..<n}"
have "strict_from_inj n f x < strict_from_inj n f y"
if xy: "x < y" and x: "x ∈ {0..<n}" and y: "y ∈ {0..<n}" for x y
proof -
let ?xs = "(sorted_list_of_set ?I)"
have sorted_xs: "sorted ?xs" by (rule sorted_sorted_list_of_set)
have "strict_from_inj n f x = (sorted_list_of_set ?I) ! x"
unfolding strict_from_inj_def using x by auto
also have "... < (sorted_list_of_set ?I) ! y"
proof (rule sorted_nth_strict_mono; clarsimp?)
show "y < card (f ` {0..<n})"
by (metis assms atLeastLessThan_iff card_atLeastLessThan card_image diff_zero y)
qed (simp add: xy)
also have "... = strict_from_inj n f y" using y unfolding strict_from_inj_def by simp
finally show ?thesis .
qed
thus ?thesis unfolding strict_mono_on_def by simp
qed
lemma strict_from_inj_image':
assumes f: "inj_on f {0..<n}"
shows "strict_from_inj n f ` {0..<n} = f`{0..<n}"
proof (auto)
let ?I = "f ` {0..<n}"
fix xa assume xa: "xa < n"
have inj_on: "inj_on f {0..<n}" using f by auto
have length_I: "length (sorted_list_of_set ?I) = n"
by (metis card_atLeastLessThan card_image diff_zero distinct_card distinct_sorted_list_of_set
finite_atLeastLessThan finite_imageI inj_on sorted_list_of_set(1))
have "strict_from_inj n f xa = sorted_list_of_set ?I ! xa"
using xa unfolding strict_from_inj_def by auto
also have "... = pick ?I xa"
by (rule sorted_list_of_set_eq_pick, unfold length_I, auto simp add: xa)
also have "... ∈ f ` {0..<n}" by (rule pick_in_set_le, simp add: card_image inj_on xa)
finally show "strict_from_inj n f xa ∈ f ` {0..<n}" .
obtain i where "sorted_list_of_set (f`{0..<n}) ! i = f xa" and "i<n"
by (metis atLeast0LessThan finite_atLeastLessThan finite_imageI imageI
in_set_conv_nth length_I lessThan_iff sorted_list_of_set(1) xa)
thus "f xa ∈ strict_from_inj n f ` {0..<n}"
by (metis atLeast0LessThan imageI lessThan_iff strict_from_inj_def)
qed
definition "Z (n::nat) (m::nat) = {(f,π)|f π. f ∈ {0..<n} → {0..<m}
∧ (∀i. i ∉ {0..<n} ⟶ f i = i)
∧ π permutes {0..<n}}"
lemma Z_alt_def: "Z n m = {f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)} × {π. π permutes {0..<n}}"
unfolding Z_def by auto
lemma det_mul_finsum_alt:
assumes A: "A ∈ carrier_mat n m"
and B: "B ∈ carrier_mat m n"
shows "det (A*B) = det (mat⇩r n n (λi. finsum_vec TYPE('a::comm_ring_1) n
(λk. B $$ (k, i) ⋅⇩v Matrix.col A k) {0..<m}))"
proof -
have AT: "A⇧T ∈ carrier_mat m n" using A by auto
have BT: "B⇧T ∈ carrier_mat n m" using B by auto
let ?f = "(λi. finsum_vec TYPE('a) n (λk. B⇧T $$ (i, k) ⋅⇩v Matrix.row A⇧T k) {0..<m})"
let ?g = "(λi. finsum_vec TYPE('a) n (λk. B $$ (k, i) ⋅⇩v Matrix.col A k) {0..<m})"
let ?lhs = "mat⇩r n n ?f"
let ?rhs = "mat⇩r n n ?g"
have lhs_rhs: "?lhs = ?rhs"
proof (rule eq_matI)
show "dim_row ?lhs = dim_row ?rhs" by auto
show "dim_col ?lhs = dim_col ?rhs" by auto
fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs"
have j_n: "j<n" using j by auto
have "?lhs $$ (i, j) = ?f i $v j" by (rule index_mat, insert i j, auto)
also have "... = (∑k∈{0..<m}. (B⇧T $$ (i, k) ⋅⇩v row A⇧T k) $ j)"
by (rule index_finsum_vec[OF _ j_n], auto simp add: A)
also have "... = (∑k∈{0..<m}. (B $$ (k, i) ⋅⇩v col A k) $ j)"
proof (rule sum.cong, auto)
fix x assume x: "x<m"
have row_rw: "Matrix.row A⇧T x = col A x" by (rule row_transpose, insert A x, auto)
have B_rw: "B⇧T $$ (i,x) = B $$ (x, i)"
by (rule index_transpose_mat, insert x i B, auto)
have "(B⇧T $$ (i, x) ⋅⇩v Matrix.row A⇧T x) $v j = B⇧T $$ (i, x) * Matrix.row A⇧T x $v j"
by (rule index_smult_vec, insert A j_n, auto)
also have "... = B $$ (x, i) * col A x $v j" unfolding row_rw B_rw by simp
also have "... = (B $$ (x, i) ⋅⇩v col A x) $v j"
by (rule index_smult_vec[symmetric], insert A j_n, auto)
finally show " (B⇧T $$ (i, x) ⋅⇩v Matrix.row A⇧T x) $v j = (B $$ (x, i) ⋅⇩v col A x) $v j" .
qed
also have "... = ?g i $v j"
by (rule index_finsum_vec[symmetric, OF _ j_n], auto simp add: A)
also have "... = ?rhs $$ (i, j)" by (rule index_mat[symmetric], insert i j, auto)
finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .
qed
have "det (A*B) = det (B⇧T*A⇧T)"
using det_transpose
by (metis A B Matrix.transpose_mult mult_carrier_mat)
also have "... = det (mat⇩r n n (λi. finsum_vec TYPE('a) n (λk. B⇧T $$ (i, k) ⋅⇩v Matrix.row A⇧T k) {0..<m}))"
using mat_mul_finsum_alt[OF BT AT] by auto
also have "... = det (mat⇩r n n (λi. finsum_vec TYPE('a) n (λk. B $$ (k, i) ⋅⇩v Matrix.col A k) {0..<m}))"
by (rule arg_cong[of _ _ det], rule lhs_rhs)
finally show ?thesis .
qed
lemma det_cols_mul:
assumes A: "A ∈ carrier_mat n m"
and B: "B ∈ carrier_mat m n"
shows "det (A*B) = (∑f | (∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i).
(∏i = 0..<n. B $$ (f i, i)) * Determinant.det (mat⇩r n n (λi. col A (f i))))"
proof -
let ?V="{0..<n}"
let ?U = "{0..<m}"
let ?F = " {f. (∀i∈ {0..<n}. f i ∈ ?U) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)}"
let ?g = "λf. det (mat⇩r n n (λ i. B $$ (f i, i) ⋅⇩v col A (f i)))"
have fm: "finite {0..<m}" by auto
have fn: "finite {0..<n}" by auto
have det_rw: "det (mat⇩r n n (λi. B $$ (f i, i) ⋅⇩v col A (f i))) =
(prod (λi. B $$ (f i, i)) {0..<n}) * det (mat⇩r n n (λi. col A (f i)))"
if f: "(∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)" for f
by (rule det_rows_mul, insert A col_dim, auto)
have "det (A*B) = det (mat⇩r n n (λi. finsum_vec TYPE('a::comm_ring_1) n (λk. B $$ (k, i) ⋅⇩v Matrix.col A k) ?U))"
by (rule det_mul_finsum_alt[OF A B])
also have "... = sum ?g ?F" by (rule det_linear_rows_sum[OF fm], auto simp add: A)
also have "... = (∑f∈?F. prod (λi. B $$ (f i, i)) {0..<n} * det (mat⇩r n n (λi. col A (f i))))"
using det_rw by auto
finally show ?thesis .
qed
lemma det_cols_mul':
assumes A: "A ∈ carrier_mat n m"
and B: "B ∈ carrier_mat m n"
shows "det (A*B) = (∑f | (∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i).
(∏i = 0..<n. A $$ (i, f i)) * det (mat⇩r n n (λi. row B (f i))))"
proof -
let ?F="{f. (∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)}"
have t: "A * B = (B⇧T*A⇧T)⇧T" using transpose_mult[OF A B] transpose_transpose by metis
have "det (B⇧T*A⇧T) = (∑f∈?F. (∏i = 0..<n. A⇧T $$ (f i, i)) * det (mat⇩r n n (λi. col B⇧T (f i))))"
by (rule det_cols_mul, auto simp add: A B)
also have "... = (∑f ∈?F. (∏i = 0..<n. A $$ (i, f i)) * det (mat⇩r n n (λi. row B (f i))))"
proof (rule sum.cong, rule refl)
fix f assume f: "f ∈ ?F"
have "(∏i = 0..<n. A⇧T $$ (f i, i)) = (∏i = 0..<n. A $$ (i, f i))"
proof (rule prod.cong, rule refl)
fix x assume x: "x ∈ {0..<n}"
show "A⇧T $$ (f x, x) = A $$ (x, f x)"
by (rule index_transpose_mat(1), insert f A x, auto)
qed
moreover have "det (mat⇩r n n (λi. col B⇧T (f i))) = det (mat⇩r n n (λi. row B (f i)))"
proof -
have row_eq_colT: "row B (f i) $v j = col B⇧T (f i) $v j" if i: "i < n" and j: "j < n" for i j
proof -
have fi_m: "f i < m" using f i by auto
have "col B⇧T (f i) $v j = B⇧T $$(j, f i)" by (rule index_col, insert B fi_m j, auto)
also have "... = B $$ (f i, j)" using B fi_m j by auto
also have "... = row B (f i) $v j" by (rule index_row[symmetric], insert B fi_m j, auto)
finally show ?thesis ..
qed
show ?thesis by (rule arg_cong[of _ _ det], rule eq_matI, insert row_eq_colT, auto)
qed
ultimately show "(∏i = 0..<n. A⇧T $$ (f i, i)) * det (mat⇩r n n (λi. col B⇧T (f i))) =
(∏i = 0..<n. A $$ (i, f i)) * det (mat⇩r n n (λi. row B (f i)))" by simp
qed
finally show ?thesis
by (metis (no_types, lifting) A B det_transpose transpose_mult mult_carrier_mat)
qed
lemma
assumes F: "F= {f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)}"
and p: " π permutes {0..<n}"
shows " (∑f∈F. (∏i = 0..<n. B $$ (f i, π i))) = (∑f∈F. (∏i = 0..<n. B $$ (f i, i)))"
proof -
let ?h = "(λf. f ∘ π)"
have inj_on_F: "inj_on ?h F"
proof (rule inj_onI)
fix f g assume fop: "f ∘ π = g ∘ π"
have "f x = g x" for x
proof (cases "x ∈ {0..<n}")
case True
then show ?thesis
by (metis fop comp_apply p permutes_def)
next
case False
then show ?thesis
by (metis fop comp_eq_elim p permutes_def)
qed
thus "f = g" by auto
qed
have hF: "?h` F = F"
unfolding image_def
proof auto
fix xa assume xa: "xa ∈ F" show "xa ∘ π ∈ F"
unfolding o_def F
using F PiE p xa
by (auto, smt F atLeastLessThan_iff mem_Collect_eq p permutes_def xa)
show "∃x∈F. xa = x ∘ π"
proof (rule bexI[of _ "xa ∘ Hilbert_Choice.inv π"])
show "xa = xa ∘ Hilbert_Choice.inv π ∘ π"
using p by auto
show "xa ∘ Hilbert_Choice.inv π ∈ F"
unfolding o_def F
using F PiE p xa
by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3))
qed
qed
have prod_rw: "(∏i = 0..<n. B $$ (f i, i)) = (∏i = 0..<n. B $$ (f (π i), π i))" if "f∈F" for f
using prod.permute[OF p] by auto
let ?g = "λf. (∏i = 0..<n. B $$ (f i, π i))"
have "(∑f∈F. (∏i = 0..<n. B $$ (f i, i))) = (∑f∈F. (∏i = 0..<n. B $$ (f (π i), π i)))"
using prod_rw by auto
also have "... = (∑f∈(?h`F). ∏i = 0..<n. B $$ (f i, π i))"
using sum.reindex[OF inj_on_F, of ?g] unfolding hF by auto
also have "... = (∑f∈F. ∏i = 0..<n. B $$ (f i, π i))" unfolding hF by auto
finally show ?thesis ..
qed
lemma detAB_Znm_aux:
assumes F: "F= {f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)}"
shows"(∑π | π permutes {0..<n}. (∑f∈F. prod (λi. B $$ (f i, i)) {0..<n}
* (signof π * (∏i = 0..<n. A $$ (π i, f i)))))
= (∑π | π permutes {0..<n}. ∑f∈F. (∏i = 0..<n. B $$ (f i, π i))
* (signof π * (∏i = 0..<n. A $$ (i, f i))))"
proof -
have "(∑π | π permutes {0..<n}. (∑f∈F. prod (λi. B $$ (f i, i)) {0..<n}
* (signof π * (∏i = 0..<n. A $$ (π i, f i))))) =
(∑π | π permutes {0..<n}. ∑f∈F. signof π * (∏i = 0..<n. B $$ (f i, i) * A $$ (π i, f i)))"
by (smt mult.left_commute prod.cong prod.distrib sum.cong)
also have "... = (∑π | π permutes {0..<n}. ∑f∈F. signof (Hilbert_Choice.inv π)
* (∏i = 0..<n. B $$ (f i, i) * A $$ (Hilbert_Choice.inv π i, f i)))"
by (rule sum_permutations_inverse)
also have "... = (∑π | π permutes {0..<n}. ∑f∈F. signof (Hilbert_Choice.inv π)
* (∏i = 0..<n. B $$ (f (π i), (π i)) * A $$ (Hilbert_Choice.inv π (π i), f (π i))))"
proof (rule sum.cong)
fix x assume x: "x ∈ {π. π permutes {0..<n}}"
let ?inv_x = "Hilbert_Choice.inv x"
have p: "x permutes {0..<n}" using x by simp
have prod_rw: "(∏i = 0..<n. B $$ (f i, i) * A $$ (?inv_x i, f i))
= (∏i = 0..<n. B $$ (f (x i), x i) * A $$ (?inv_x (x i), f (x i)))" if "f ∈ F" for f
using prod.permute[OF p] by auto
then show "(∑f∈F. signof ?inv_x * (∏i = 0..<n. B $$ (f i, i) * A $$ (?inv_x i, f i))) =
(∑f∈F. signof ?inv_x * (∏i = 0..<n. B $$ (f (x i), x i) * A $$ (?inv_x (x i), f (x i))))"
by auto
qed (simp)
also have "... = (∑π | π permutes {0..<n}. ∑f∈F. signof π
* (∏i = 0..<n. B $$ (f (π i), (π i)) * A $$ (i, f (π i))))"
by (rule sum.cong, auto, rule sum.cong, auto)
(metis (no_types, lifting) finite_atLeastLessThan signof_inv)
also have "... = (∑π | π permutes {0..<n}. ∑f∈F. signof π
* (∏i = 0..<n. B $$ (f i, (π i)) * A $$ (i, f i)))"
proof (rule sum.cong)
fix π assume p: "π ∈ {π. π permutes {0..<n}}"
hence p: "π permutes {0..<n}" by auto
let ?inv_pi = "(Hilbert_Choice.inv π)"
let ?h = "(λf. f ∘ (Hilbert_Choice.inv π))"
have inj_on_F: "inj_on ?h F"
proof (rule inj_onI)
fix f g assume fop: "f ∘ ?inv_pi = g ∘ ?inv_pi"
have "f x = g x" for x
proof (cases "x ∈ {0..<n}")
case True
then show ?thesis
by (metis fop o_inv_o_cancel p permutes_inj)
next
case False
then show ?thesis
by (metis fop o_inv_o_cancel p permutes_inj)
qed
thus "f = g" by auto
qed
have hF: "?h` F = F"
unfolding image_def
proof auto
fix xa assume xa: "xa ∈ F" show "xa ∘ ?inv_pi ∈ F"
unfolding o_def F
using F PiE p xa
by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3))
show "∃x∈F. xa = x ∘ ?inv_pi"
proof (rule bexI[of _ "xa ∘ π"])
show "xa = xa ∘ π ∘ Hilbert_Choice.inv π "
using p by auto
show "xa ∘ π ∈ F"
unfolding o_def F
using F PiE p xa
by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3))
qed
qed
let ?g = "λf. signof π * (∏i = 0..<n. B $$ (f (π i), π i) * A $$ (i, f (π i)))"
show "(∑f∈F. signof π * (∏i = 0..<n. B $$ (f (π i), π i) * A $$ (i, f (π i)))) =
(∑f∈F. signof π * (∏i = 0..<n. B $$ (f i, π i) * A $$ (i, f i)))"
using sum.reindex[OF inj_on_F, of "?g"] p unfolding hF unfolding o_def by auto
qed (simp)
also have "... = (∑π | π permutes {0..<n}. ∑f∈F. (∏i = 0..<n. B $$ (f i, π i))
* (signof π * (∏i = 0..<n. A $$ (i, f i))))"
by (smt mult.left_commute prod.cong prod.distrib sum.cong)
finally show ?thesis .
qed
lemma detAB_Znm:
assumes A: "A ∈ carrier_mat n m"
and B: "B ∈ carrier_mat m n"
shows "det (A*B) = (∑(f, π)∈Z n m. signof π * (∏i = 0..<n. A $$ (i, f i) * B $$ (f i, π i)))"
proof -
let ?V="{0..<n}"
let ?U = "{0..<m}"
let ?PU = "{p. p permutes ?U}"
let ?F = " {f. (∀i∈ {0..<n}. f i ∈ ?U) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)}"
let ?f = "λf. det (mat⇩r n n (λ i. A $$ (i, f i) ⋅⇩v row B (f i)))"
let ?g = "λf. det (mat⇩r n n (λ i. B $$ (f i, i) ⋅⇩v col A (f i)))"
have fm: "finite {0..<m}" by auto
have fn: "finite {0..<n}" by auto
have F: "?F= {f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)}" by auto
have det_rw: "det (mat⇩r n n (λi. B $$ (f i, i) ⋅⇩v col A (f i))) =
(prod (λi. B $$ (f i, i)) {0..<n}) * det (mat⇩r n n (λi. col A (f i)))"
if f: "(∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)" for f
by (rule det_rows_mul, insert A col_dim, auto)
have det_rw2: "det (mat⇩r n n (λi. col A (f i)))
= (∑π | π permutes {0..<n}. signof π * (∏i = 0..<n. A $$ (π i, f i)))"
if f: "f ∈ ?F" for f
proof (unfold Determinant.det_def, auto, rule sum.cong, auto)
fix x assume x: "x permutes {0..<n}"
have "(∏i = 0..<n. col A (f i) $v x i) = (∏i = 0..<n. A $$ (x i, f i))"
proof (rule prod.cong)
fix xa assume xa: "xa ∈ {0..<n}" show "col A (f xa) $v x xa = A $$ (x xa, f xa)"
by (metis A atLeastLessThan_iff carrier_matD(1) col_def index_vec permutes_less(1) x xa)
qed (auto)
then show "signof x * (∏i = 0..<n. col A (f i) $v x i)
= signof x * (∏i = 0..<n. A $$ (x i, f i))" by auto
qed
have fin_n: "finite {0..<n}" and fin_m: "finite {0..<m}" by auto
have "det (A*B) = det (mat⇩r n n (λi. finsum_vec TYPE('a::comm_ring_1) n
(λk. B $$ (k, i) ⋅⇩v Matrix.col A k) {0..<m}))"
by (rule det_mul_finsum_alt[OF A B])
also have "... = sum ?g ?F" by (rule det_linear_rows_sum[OF fm], auto simp add: A)
also have "... = (∑f∈?F. prod (λi. B $$ (f i, i)) {0..<n} * det (mat⇩r n n (λi. col A (f i))))"
using det_rw by auto
also have "... = (∑f∈?F. prod (λi. B $$ (f i, i)) {0..<n} *
(∑π | π permutes {0..<n}. signof π * (∏i = 0..<n. A $$ (π i, f (i)))))"
by (rule sum.cong, auto simp add: det_rw2)
also have "... =
(∑f∈?F. ∑π | π permutes {0..<n}. prod (λi. B $$ (f i, i)) {0..<n}
* (signof π * (∏i = 0..<n. A $$ (π i, f (i)))))"
by (simp add: mult_hom.hom_sum)
also have "... = (∑π | π permutes {0..<n}. ∑f∈?F.prod (λi. B $$ (f i, i)) {0..<n}
* (signof π * (∏i = 0..<n. A $$ (π i, f i))))"
by (rule VS_Connect.class_semiring.finsum_finsum_swap,
insert finite_permutations finite_bounded_functions[OF fin_m fin_n], auto)
thm detAB_Znm_aux
also have "... = (∑π | π permutes {0..<n}. ∑f∈?F. (∏i = 0..<n. B $$ (f i, π i))
* (signof π * (∏i = 0..<n. A $$ (i, f i))))" by (rule detAB_Znm_aux, auto)
also have "... = (∑f∈?F.∑π | π permutes {0..<n}. (∏i = 0..<n. B $$ (f i, π i))
* (signof π * (∏i = 0..<n. A $$ (i, f i))))"
by (rule VS_Connect.class_semiring.finsum_finsum_swap,
insert finite_permutations finite_bounded_functions[OF fin_m fin_n], auto)
also have "... = (∑f∈?F.∑π | π permutes {0..<n}. signof π
* (∏i = 0..<n. A $$ (i, f i) * B $$ (f i, π i)))"
unfolding prod.distrib by (rule sum.cong, auto, rule sum.cong, auto)
also have "... = sum (λ(f,π). (signof π)
* (prod (λi. A$$(i,f i) * B $$ (f i, π i)) {0..<n})) (Z n m)"
unfolding Z_alt_def unfolding sum.cartesian_product[symmetric] F by auto
finally show ?thesis .
qed
context
fixes n m and A B::"'a::comm_ring_1 mat"
assumes A: "A ∈ carrier_mat n m"
and B: "B ∈ carrier_mat m n"
begin
private definition "Z_inj = ({f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)
∧ inj_on f {0..<n}} × {π. π permutes {0..<n}})"
private definition "Z_not_inj = ({f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)
∧ ¬ inj_on f {0..<n}} × {π. π permutes {0..<n}})"
private definition "Z_strict = ({f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)
∧ strict_mono_on f {0..<n}} × {π. π permutes {0..<n}})"
private definition "Z_not_strict = ({f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)
∧ ¬ strict_mono_on f {0..<n}} × {π. π permutes {0..<n}})"
private definition "weight f π
= (signof π) * (prod (λi. A$$(i,f i) * B $$ (f i, π i)) {0..<n})"
private definition "Z_good g = ({f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)
∧ inj_on f {0..<n} ∧ (f`{0..<n} = g`{0..<n})} × {π. π permutes {0..<n}})"
private definition "F_strict = {f. f ∈ {0..<n} → {0..<m}
∧ (∀i. i ∉ {0..<n} ⟶ f i = i) ∧ strict_mono_on f {0..<n}}"
private definition "F_inj = {f. f ∈ {0..<n} → {0..<m}
∧ (∀i. i ∉ {0..<n} ⟶ f i = i) ∧ inj_on f {0..<n}}"
private definition "F_not_inj = {f. f ∈ {0..<n} → {0..<m}
∧ (∀i. i ∉ {0..<n} ⟶ f i = i) ∧ ¬ inj_on f {0..<n}}"
private definition "F = {f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)}"
text‹The Cauchy--Binet formula is proven in \url{https://core.ac.uk/download/pdf/82475020.pdf}
In that work, they define @{text "σ ≡ inv φ ∘ π"}. I had problems following this proof
in Isabelle, since I was demanded to show that such permutations commute, which is false.
It is a notation problem of the @{text "∘"} operator, the author means @{text "σ ≡ π ∘ inv φ"} using
the Isabelle notation (i.e., @{text "σ x = π ((inv φ) x)"}).
›
lemma step_weight:
fixes φ π
defines "σ ≡ π ∘ Hilbert_Choice.inv φ"
assumes f_inj: "f ∈ F_inj" and gF: "g ∈ F" and pi: "π permutes {0..<n}"
and phi: "φ permutes {0..<n}" and fg_phi: "∀x ∈ {0..<n}. f x = g (φ x)"
shows "weight f π = (signof φ) * (∏i = 0..<n. A $$ (i, g (φ i)))
* (signof σ) * (∏i = 0..<n. B $$ (g i, σ i))"
proof -
let ?A = "(∏i = 0..<n. A $$ (i, g (φ i))) "
let ?B = "(∏i = 0..<n. B $$ (g i, σ i))"
have sigma: "σ permutes {0..<n}" unfolding σ_def
by (rule permutes_compose[OF permutes_inv[OF phi] pi])
have A_rw: "?A = (∏i = 0..<n. A $$ (i, f i))" using fg_phi by auto
have "?B = (∏i = 0..<n. B $$ (g (φ i), σ (φ i)))"
by (rule prod.permute[unfolded o_def, OF phi])
also have "... = (∏i = 0..<n. B $$ (f i, π i))"
using fg_phi
unfolding σ_def unfolding o_def unfolding permutes_inverses(2)[OF phi] by auto
finally have B_rw: "?B = (∏i = 0..<n. B $$ (f i, π i))" .
have "(signof φ) * ?A * (signof σ) * ?B = (signof φ) * (signof σ) * ?A * ?B" by auto
also have "... = signof (φ ∘ σ) * ?A * ?B" unfolding signof_compose[OF phi sigma] by simp
also have "... = signof π * ?A * ?B"
by (metis (no_types, lifting) σ_def mult.commute o_inv_o_cancel permutes_inj
phi sigma signof_compose)
also have "... = signof π * (∏i = 0..<n. A $$ (i, f i)) * (∏i = 0..<n. B $$ (f i, π i))"
using A_rw B_rw by auto
also have "... = signof π * (∏i = 0..<n. A $$ (i, f i) * B $$ (f i, π i))" by auto
also have "... = weight f π" unfolding weight_def by simp
finally show ?thesis ..
qed
lemma Z_good_fun_alt_sum:
fixes g
defines "Z_good_fun ≡ {f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)
∧ inj_on f {0..<n} ∧ (f`{0..<n} = g`{0..<n})}"
assumes g: "g ∈ F_inj"
shows "(∑f∈Z_good_fun. P f)= (∑π∈{π. π permutes {0..<n}}. P (g ∘ π))"
proof -
let ?f = "λπ. g ∘ π"
let ?P = "{π. π permutes {0..<n}}"
have fP: "?f`?P = Z_good_fun"
proof (unfold Z_good_fun_def, auto)
fix xa xb assume "xa permutes {0..<n}" and "xb < n"
hence "xa xb < n" by auto
thus "g (xa xb) < m" using g unfolding F_inj_def by fastforce
next
fix xa i assume "xa permutes {0..<n}" and i_ge_n: "¬ i < n"
hence "xa i = i" unfolding permutes_def by auto
thus "g (xa i) = i" using g i_ge_n unfolding F_inj_def by auto
next
fix xa assume "xa permutes {0..<n}" thus "inj_on (g ∘ xa) {0..<n}"
by (metis (mono_tags, lifting) F_inj_def atLeast0LessThan comp_inj_on g
mem_Collect_eq permutes_image permutes_inj_on)
next
fix π xb assume "π permutes {0..<n}" and "xb < n" thus " g xb ∈ (λx. g (π x)) ` {0..<n}"
by (metis (full_types) atLeast0LessThan imageI image_image lessThan_iff permutes_image)
next
fix x assume x1: "x ∈ {0..<n} → {0..<m}" and x2: "∀i. ¬ i < n ⟶ x i = i"
and inj_on_x: "inj_on x {0..<n}" and xg: "x ` {0..<n} = g ` {0..<n}"
let ?τ = "λi. if i<n then (THE j. j<n ∧ x i = g j) else i"
show "x ∈ (∘) g ` {π. π permutes {0..<n}}"
proof (unfold image_def, auto, rule exI[of _ ?τ], rule conjI)
have "?τ i = i" if i: "i ∉ {0..<n}" for i
using i by auto
moreover have "∃!j. ?τ j = i" for i
proof (cases "i<n")
case True
obtain a where xa_gi: "x a = g i" and a: "a < n" using xg True
by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff)
show ?thesis
proof (rule ex1I[of _ a])
have the_ai: "(THE j. j < n ∧ x a = g j) = i"
proof (rule theI2)
show "i < n ∧ x a = g i" using xa_gi True by auto
fix xa assume "xa < n ∧ x a = g xa" thus "xa = i"
by (metis (mono_tags, lifting) F_inj_def True atLeast0LessThan
g inj_onD lessThan_iff mem_Collect_eq xa_gi)
thus "xa = i" .
qed
thus ta: "?τ a = i" using a by auto
fix j assume tj: "?τ j = i"
show "j = a"
proof (cases "j<n")
case True
obtain b where xj_gb: "x j = g b" and b: "b < n" using xg True
by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff)
let ?P = "λja. ja < n ∧ x j = g ja"
have the_ji: "(THE ja. ja < n ∧ x j = g ja) = i" using tj True by auto
have "?P (THE ja. ?P ja)"
proof (rule theI)
show "b < n ∧ x j = g b" using xj_gb b by auto
fix xa assume "xa < n ∧ x j = g xa" thus "xa = b"
by (metis (mono_tags, lifting) F_inj_def b atLeast0LessThan
g inj_onD lessThan_iff mem_Collect_eq xj_gb)
qed
hence "x j = g i" unfolding the_ji by auto
hence "x j = x a" using xa_gi by auto
then show ?thesis using inj_on_x a True unfolding inj_on_def by auto
next
case False
then show ?thesis using tj True by auto
qed
qed
next
case False note i_ge_n = False
show ?thesis
proof (rule ex1I[of _ i])
show "?τ i = i" using False by simp
fix j assume tj: "?τ j = i"
show "j = i"
proof (cases "j<n")
case True
obtain a where xj_ga: "x j = g a" and a: "a < n" using xg True
by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff)
have "(THE ja. ja < n ∧ x j = g ja) < n"
proof (rule theI2)
show "a < n ∧ x j = g a" using xj_ga a by auto
fix xa assume a1: "xa < n ∧ x j = g xa" thus "xa = a"
using F_inj_def a atLeast0LessThan g inj_on_eq_iff xj_ga by fastforce
show "xa < n" by (simp add: a1)
qed
then show ?thesis using tj i_ge_n by auto
next
case False
then show ?thesis using tj by auto
qed
qed
qed
ultimately show "?τ permutes {0..<n}" unfolding permutes_def by auto
show "x = g ∘ ?τ"
proof -
have "x xa = g (THE j. j < n ∧ x xa = g j)" if xa: "xa < n" for xa
proof -
obtain c where c: "c < n" and xxa_gc: "x xa = g c"
by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff xa xg)
show ?thesis
proof (rule theI2)
show c1: "c < n ∧ x xa = g c" using c xxa_gc by auto
fix xb assume c2: "xb < n ∧ x xa = g xb" thus "xb = c"
by (metis (mono_tags, lifting) F_inj_def c1 atLeast0LessThan
g inj_onD lessThan_iff mem_Collect_eq)
show "x xa = g xb" using c1 c2 by simp
qed
qed
moreover have "x xa = g xa" if xa: "¬ xa < n" for xa
using g x1 x2 xa unfolding F_inj_def by simp
ultimately show ?thesis unfolding o_def fun_eq_iff by auto
qed
qed
qed
have inj: "inj_on ?f ?P"
proof (rule inj_onI)
fix x y assume x: "x ∈ ?P" and y: "y ∈ ?P" and gx_gy: "g ∘ x = g ∘ y"
have "x i = y i" for i
proof (cases "i<n")
case True
hence xi: "x i ∈ {0..<n}" and yi: "y i ∈ {0..<n}" using x y by auto
have "g (x i) = g (y i)" using gx_gy unfolding o_def by meson
thus ?thesis using xi yi using g unfolding F_inj_def inj_on_def by blast
next
case False
then show ?thesis using x y unfolding permutes_def by auto
qed
thus "x = y" unfolding fun_eq_iff by auto
qed
have "(∑f∈Z_good_fun. P f) = (∑f∈?f`?P. P f)" using fP by simp
also have "... = sum (P ∘ (∘) g) {π. π permutes {0..<n}}"
by (rule sum.reindex[OF inj])
also have "... = (∑π | π permutes {0..<n}. P (g ∘ π))" by auto
finally show ?thesis .
qed
lemma F_injI:
assumes "f ∈ {0..<n} → {0..<m}"
and "(∀i. i ∉ {0..<n} ⟶ f i = i)" and "inj_on f {0..<n}"
shows "f ∈ F_inj" using assms unfolding F_inj_def by simp
lemma F_inj_composition_permutation:
assumes phi: "φ permutes {0..<n}"
and g: "g ∈ F_inj"
shows "g ∘ φ ∈ F_inj"
proof (rule F_injI)
show "g ∘ φ ∈ {0..<n} → {0..<m}"
using g unfolding permutes_def F_inj_def
by (simp add: Pi_iff phi)
show "∀i. i ∉ {0..<n} ⟶ (g ∘ φ) i = i"
using g phi unfolding permutes_def F_inj_def by simp
show "inj_on (g ∘ φ) {0..<n}"
by (rule comp_inj_on, insert g permutes_inj_on[OF phi] permutes_image[OF phi])
(auto simp add: F_inj_def)
qed
lemma F_strict_imp_F_inj:
assumes f: "f ∈ F_strict"
shows "f ∈ F_inj"
using f strict_mono_on_imp_inj_on
unfolding F_strict_def F_inj_def by auto
lemma one_step:
assumes g1: "g ∈ F_strict"
shows "det (submatrix A UNIV (g`{0..<n})) * det (submatrix B (g`{0..<n}) UNIV)
= (∑(x, y) ∈ Z_good g. weight x y)" (is "?lhs = ?rhs")
proof -
define Z_good_fun where "Z_good_fun = {f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)
∧ inj_on f {0..<n} ∧ (f`{0..<n} = g`{0..<n})}"
let ?Perm = "{π. π permutes {0..<n}}"
let ?P = "(λf. ∑π ∈ ?Perm. weight f π)"
let ?inv = "Hilbert_Choice.inv"
have g: "g ∈ F_inj" by (rule F_strict_imp_F_inj[OF g1])
have detA: "(∑φ∈{π. π permutes {0..<n}}. signof φ * (∏i = 0..<n. A $$ (i, g (φ i))))
= det (submatrix A UNIV (g`{0..<n}))"
proof -
have "{j. j < dim_col A ∧ j ∈ g ` {0..<n}} = {j. j ∈ g ` {0..<n}}"
using g A unfolding F_inj_def by fastforce
also have "card ... = n" using F_inj_def card_image g by force
finally have card_J: "card {j. j < dim_col A ∧ j ∈ g ` {0..<n}} = n" by simp
have subA_carrier: "submatrix A UNIV (g ` {0..<n}) ∈ carrier_mat n n"
unfolding submatrix_def card_J using A by auto
have "det (submatrix A UNIV (g`{0..<n})) = (∑p | p permutes {0..<n}.
signof p * (∏i = 0..<n. submatrix A UNIV (g ` {0..<n}) $$ (i, p i)))"
using subA_carrier unfolding Determinant.det_def by auto
also have "... = (∑φ∈{π. π permutes {0..<n}}. signof φ * (∏i = 0..<n. A $$ (i, g (φ i))))"
proof (rule sum.cong)
fix x assume x: "x ∈ {π. π permutes {0..<n}}"
have "(∏i = 0..<n. submatrix A UNIV (g ` {0..<n}) $$ (i, x i))
= (∏i = 0..<n. A $$ (i, g (x i)))"
proof (rule prod.cong, rule refl)
fix i assume i: "i ∈ {0..<n}"
have pick_rw: "pick (g ` {0..<n}) (x i) = g (x i)"
proof -
have "index (sorted_list_of_set (g ` {0..<n})) (g (x i)) = x i"
proof -
have rw: "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
by (rule sorted_list_of_set_map_strict, insert g1, simp add: F_strict_def)
have "index (sorted_list_of_set (g`{0..<n})) (g (x i)) = index (map g [0..<n]) (g (x i))"
unfolding rw by auto
also have "... = index [0..<n] (x i)"
by (rule index_map_inj_on[of _ "{0..<n}"], insert x i g, auto simp add: F_inj_def)
also have "... = x i" using x i by auto
finally show ?thesis .
qed
moreover have "(g (x i)) ∈ (g ` {0..<n})" using x g i unfolding F_inj_def by auto
moreover have "x i < card (g ` {0..<n})" using x i g by (simp add: F_inj_def card_image)
ultimately show ?thesis using pick_index by auto
qed
have "submatrix A UNIV (g`{0..<n}) $$ (i, x i) = A $$ (pick UNIV i, pick (g`{0..<n}) (x i))"
by (rule submatrix_index, insert i A card_J x, auto)
also have "... = A $$ (i, g (x i))" using pick_rw pick_UNIV by auto
finally show "submatrix A UNIV (g ` {0..<n}) $$ (i, x i) = A $$ (i, g (x i))" .
qed
thus "signof x * (∏i = 0..<n. submatrix A UNIV (g ` {0..<n}) $$ (i, x i))
= signof x * (∏i = 0..<n. A $$ (i, g (x i)))" by auto
qed (simp)
finally show ?thesis by simp
qed
have detB_rw: "(∑π ∈ ?Perm. signof (π ∘ ?inv φ) * (∏i = 0..<n. B $$ (g i, (π ∘ ?inv φ) i)))
= (∑π ∈ ?Perm. signof (π) * (∏i = 0..<n. B $$ (g i, π i)))"
if phi: "φ permutes {0..<n}" for φ
proof -
let ?h="λπ. π ∘ ?inv φ"
let ?g = "λπ. signof (π) * (∏i = 0..<n. B $$ (g i, π i))"
have "?h`?Perm = ?Perm"
proof -
have "π ∘ ?inv φ permutes {0..<n}" if pi: "π permutes {0..<n}" for π
using permutes_compose permutes_inv phi that by blast
moreover have "x ∈ (λπ. π ∘ ?inv φ) ` ?Perm" if "x permutes {0..<n}" for x
proof -
have "x ∘ φ permutes {0..<n}"
using permutes_compose phi that by blast
moreover have "x = x ∘ φ ∘ ?inv φ" using phi by auto
ultimately show ?thesis unfolding image_def by auto
qed
ultimately show ?thesis by auto
qed
hence "(∑π ∈ ?Perm. ?g π) = (∑π ∈ ?h`?Perm. ?g π)" by simp
also have "... = sum (?g ∘ ?h) ?Perm"
proof (rule sum.reindex)
show "inj_on (λπ. π ∘ ?inv φ) {π. π permutes {0..<n}}"
by (metis (no_types, lifting) inj_onI o_inv_o_cancel permutes_inj phi)
qed
also have "... = (∑π ∈ ?Perm. signof (π ∘ ?inv φ) * (∏i = 0..<n. B $$ (g i, (π ∘ ?inv φ) i)))"
unfolding o_def by auto
finally show ?thesis by simp
qed
have detB: "det (submatrix B (g`{0..<n}) UNIV)
= (∑π ∈ ?Perm. signof π * (∏i = 0..<n. B $$ (g i, π i)))"
proof -
have "{i. i < dim_row B ∧ i ∈ g ` {0..<n}} = {i. i ∈ g ` {0..<n}}"
using g B unfolding F_inj_def by fastforce
also have "card ... = n" using F_inj_def card_image g by force
finally have card_I: "card {j. j < dim_row B ∧ j ∈ g ` {0..<n}} = n" by simp
have subB_carrier: "submatrix B (g ` {0..<n}) UNIV ∈ carrier_mat n n"
unfolding submatrix_def using card_I B by auto
have "det (submatrix B (g`{0..<n}) UNIV) = (∑p ∈ ?Perm. signof p
* (∏i=0..<n. submatrix B (g ` {0..<n}) UNIV $$ (i, p i)))"
unfolding Determinant.det_def using subB_carrier by auto
also have "... = (∑π ∈ ?Perm. signof π * (∏i = 0..<n. B $$ (g i, π i)))"
proof (rule sum.cong, rule refl)
fix x assume x: "x ∈ {π. π permutes {0..<n}}"
have "(∏i=0..<n. submatrix B (g`{0..<n}) UNIV $$ (i, x i)) = (∏i=0..<n. B $$ (g i, x i))"
proof (rule prod.cong, rule refl)
fix i assume i: "i ∈ {0..<n}"
have pick_rw: "pick (g ` {0..<n}) i = g i"
proof -
have "index (sorted_list_of_set (g ` {0..<n})) (g i) = i"
proof -
have rw: "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
by (rule sorted_list_of_set_map_strict, insert g1, simp add: F_strict_def)
have "index (sorted_list_of_set (g`{0..<n})) (g i) = index (map g [0..<n]) (g i)"
unfolding rw by auto
also have "... = index [0..<n] (i)"
by (rule index_map_inj_on[of _ "{0..<n}"], insert x i g, auto simp add: F_inj_def)
also have "... = i" using i by auto
finally show ?thesis .
qed
moreover have "(g i) ∈ (g ` {0..<n})" using x g i unfolding F_inj_def by auto
moreover have "i < card (g ` {0..<n})" using x i g by (simp add: F_inj_def card_image)
ultimately show ?thesis using pick_index by auto
qed
have "submatrix B (g`{0..<n}) UNIV $$ (i, x i) = B $$ (pick (g`{0..<n}) i, pick UNIV (x i))"
by (rule submatrix_index, insert i B card_I x, auto)
also have "... = B $$ (g i, x i)" using pick_rw pick_UNIV by auto
finally show "submatrix B (g ` {0..<n}) UNIV $$ (i, x i) = B $$ (g i, x i)" .
qed
thus "signof x * (∏i = 0..<n. submatrix B (g ` {0..<n}) UNIV $$ (i, x i))
= signof x * (∏i = 0..<n. B $$ (g i, x i))" by simp
qed
finally show ?thesis .
qed
have "?rhs = (∑f∈Z_good_fun. ∑π∈?Perm. weight f π)"
unfolding Z_good_def sum.cartesian_product Z_good_fun_def by blast
also have "... = (∑φ∈{π. π permutes {0..<n}}. ?P (g ∘ φ))" unfolding Z_good_fun_def
by (rule Z_good_fun_alt_sum[OF g])
also have "... = (∑φ∈{π. π permutes {0..<n}}. ∑π∈{π. π permutes {0..<n}}.
signof φ * (∏i = 0..<n. A $$ (i, g (φ i))) * signof (π ∘ ?inv φ)
* (∏i = 0..<n. B $$ (g i, (π ∘ ?inv φ) i)))"
proof (rule sum.cong, simp, rule sum.cong, simp)
fix φ π assume phi: "φ ∈ ?Perm" and pi: "π ∈ ?Perm"
show "weight (g ∘ φ) π = signof φ * (∏i = 0..<n. A $$ (i, g (φ i))) *
signof (π ∘ ?inv φ) * (∏i = 0..<n. B $$ (g i, (π ∘ ?inv φ) i))"
proof (rule step_weight)
show "g ∘ φ ∈ F_inj" by (rule F_inj_composition_permutation[OF _ g], insert phi, auto)
show "g ∈ F" using g unfolding F_def F_inj_def by simp
qed (insert phi pi, auto)
qed
also have "... = (∑φ∈{π. π permutes {0..<n}}. signof φ * (∏i = 0..<n. A $$ (i, g (φ i))) *
(∑π | π permutes {0..<n}. signof (π ∘ ?inv φ) * (∏i = 0..<n. B $$ (g i, (π ∘ ?inv φ) i))))"
by (metis (mono_tags, lifting) Groups.mult_ac(1) semiring_0_class.sum_distrib_left sum.cong)
also have "... = (∑φ ∈ ?Perm. signof φ * (∏i = 0..<n. A $$ (i, g (φ i))) *
(∑π ∈ ?Perm. signof π * (∏i = 0..<n. B $$ (g i, π i))))" using detB_rw by auto
also have "... = (∑φ ∈ ?Perm. signof φ * (∏i = 0..<n. A $$ (i, g (φ i)))) *
(∑π ∈ ?Perm. signof π * (∏i = 0..<n. B $$ (g i, π i)))"
by (simp add: semiring_0_class.sum_distrib_right)
also have "... = ?lhs" unfolding detA detB ..
finally show ?thesis ..
qed
lemma gather_by_strictness:
"sum (λg. sum (λ(f,π). weight f π) (Z_good g)) F_strict
= sum (λg. det (submatrix A UNIV (g`{0..<n})) * det (submatrix B (g`{0..<n}) UNIV)) F_strict"
proof (rule sum.cong)
fix f assume f: "f ∈ F_strict"
show "(∑(x, y)∈Z_good f. weight x y)
= det (submatrix A UNIV (f ` {0..<n})) * det (submatrix B (f ` {0..<n}) UNIV)"
by (rule one_step[symmetric], rule f)
qed (simp)
lemma finite_Z_strict[simp]: "finite Z_strict"
proof (unfold Z_strict_def, rule finite_cartesian_product)
have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
let ?A="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i) ∧ strict_mono_on f {0..<n}}"
let ?B="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i)}"
have B: "{f. (∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)} = ?B" by auto
have "?A⊆?B" by auto
moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
ultimately show "finite ?A" using rev_finite_subset by blast
show "finite {π. π permutes {0..<n}}" using finite_permutations by blast
qed
lemma finite_Z_not_strict[simp]: "finite Z_not_strict"
proof (unfold Z_not_strict_def, rule finite_cartesian_product)
have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
let ?A="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i) ∧ ¬ strict_mono_on f {0..<n}}"
let ?B="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i)}"
have B: "{f. (∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)} = ?B" by auto
have "?A⊆?B" by auto
moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
ultimately show "finite ?A" using rev_finite_subset by blast
show "finite {π. π permutes {0..<n}}" using finite_permutations by blast
qed
lemma finite_Znm[simp]: "finite (Z n m)"
proof (unfold Z_alt_def, rule finite_cartesian_product)
have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
let ?A="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i) }"
let ?B="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i)}"
have B: "{f. (∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)} = ?B" by auto
have "?A⊆?B" by auto
moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
ultimately show "finite ?A" using rev_finite_subset by blast
show "finite {π. π permutes {0..<n}}" using finite_permutations by blast
qed
lemma finite_F_inj[simp]: "finite F_inj"
proof -
have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
let ?A="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i) ∧ inj_on f {0..<n}}"
let ?B="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i)}"
have B: "{f. (∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)} = ?B" by auto
have "?A⊆?B" by auto
moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
ultimately show "finite F_inj" unfolding F_inj_def using rev_finite_subset by blast
qed
lemma finite_F_strict[simp]: "finite F_strict"
proof -
have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
let ?A="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i) ∧ strict_mono_on f {0..<n}}"
let ?B="{f ∈ {0..<n} → {0..<m}. (∀i. i ∉ {0..<n} ⟶ f i = i)}"
have B: "{f. (∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)} = ?B" by auto
have "?A⊆?B" by auto
moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
ultimately show "finite F_strict" unfolding F_strict_def using rev_finite_subset by blast
qed
lemma nth_strict_mono:
fixes f::"nat ⇒ nat"
assumes strictf: "strict_mono f" and i: "i<n"
shows "f i = (sorted_list_of_set (f`{0..<n})) ! i"
proof -
let ?I = "f`{0..<n}"
have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
by (metis distinct_card finite_atLeastLessThan finite_imageI
sorted_list_of_set(1) sorted_list_of_set(3))
also have "... = n"
by (simp add: card_image strict_mono_imp_inj_on strictf)
finally have length_I: "length (sorted_list_of_set ?I) = n" .
have card_eq: "card {a ∈ ?I. a < f i} = i"
using i
proof (induct i)
case 0
then show ?case
by (auto simp add: strict_mono_less strictf)
next
case (Suc i)
have i: "i < n" using Suc.prems by auto
let ?J'="{a ∈ f ` {0..<n}. a < f i}"
let ?J = "{a ∈ f ` {0..<n}. a < f (Suc i)}"
have cardJ': "card ?J' = i" by (rule Suc.hyps[OF i])
have J: "?J = insert (f i) ?J'"
proof (auto)
fix xa assume 1: "f xa ≠ f i" and 2: "f xa < f (Suc i)"
show "f xa < f i"
using 1 2 not_less_less_Suc_eq strict_mono_less strictf by fastforce
next
fix xa assume "f xa < f i" thus "f xa < f (Suc i)"
using less_SucI strict_mono_less strictf by blast
next
show "f i ∈ f ` {0..<n}" using i by auto
show "f i < f (Suc i)" using strictf strict_mono_less by auto
qed
have "card ?J = Suc (card ?J')" by (unfold J, rule card_insert_disjoint, auto)
then show ?case using cardJ' by auto
qed
have "sorted_list_of_set ?I ! i = pick ?I i"
by (rule sorted_list_of_set_eq_pick, simp add: ‹card (f ` {0..<n}) = n› i)
also have "... = pick ?I (card {a ∈ ?I. a < f i})" unfolding card_eq by simp
also have "... = f i" by (rule pick_card_in_set, simp add: i)
finally show ?thesis ..
qed
lemma nth_strict_mono_on:
fixes f::"nat ⇒ nat"
assumes strictf: "strict_mono_on f {0..<n}" and i: "i<n"
shows "f i = (sorted_list_of_set (f`{0..<n})) ! i"
proof -
let ?I = "f`{0..<n}"
have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
by (metis distinct_card finite_atLeastLessThan finite_imageI
sorted_list_of_set(1) sorted_list_of_set(3))
also have "... = n"
by (metis (mono_tags, lifting) card_atLeastLessThan card_image diff_zero
inj_on_def strict_mono_on_eqD strictf)
finally have length_I: "length (sorted_list_of_set ?I) = n" .
have card_eq: "card {a ∈ ?I. a < f i} = i"
using i
proof (induct i)
case 0
then show ?case
by (auto, metis (no_types, lifting) atLeast0LessThan lessThan_iff less_Suc_eq
not_less0 not_less_eq strict_mono_on_def strictf)
next
case (Suc i)
have i: "i < n" using Suc.prems by auto
let ?J'="{a ∈ f ` {0..<n}. a < f i}"
let ?J = "{a ∈ f ` {0..<n}. a < f (Suc i)}"
have cardJ': "card ?J' = i" by (rule Suc.hyps[OF i])
have J: "?J = insert (f i) ?J'"
proof (auto)
fix xa assume 1: "f xa ≠ f i" and 2: "f xa < f (Suc i)" and 3: "xa < n"
show "f xa < f i"
by (metis (full_types) 1 2 3 antisym_conv3 atLeast0LessThan i lessThan_iff
less_SucE order.asym strict_mono_onD strictf)
next
fix xa assume "f xa < f i" and "xa < n" thus "f xa < f (Suc i)"
using less_SucI strictf
by (metis (no_types, lifting) Suc.prems atLeast0LessThan
lessI lessThan_iff less_trans strict_mono_onD)
next
show "f i ∈ f ` {0..<n}" using i by auto
show "f i < f (Suc i)"
using Suc.prems strict_mono_onD strictf by fastforce
qed
have "card ?J = Suc (card ?J')" by (unfold J, rule card_insert_disjoint, auto)
then show ?case using cardJ' by auto
qed
have "sorted_list_of_set ?I ! i = pick ?I i"
by (rule sorted_list_of_set_eq_pick, simp add: ‹card (f ` {0..<n}) = n› i)
also have "... = pick ?I (card {a ∈ ?I. a < f i})" unfolding card_eq by simp
also have "... = f i" by (rule pick_card_in_set, simp add: i)
finally show ?thesis ..
qed
lemma strict_fun_eq:
assumes f: "f ∈ F_strict" and g: "g ∈ F_strict" and fg: "f`{0..<n} = g`{0..<n}"
shows "f = g"
proof (unfold fun_eq_iff, auto)
fix x
show "f x = g x"
proof (cases "x<n")
case True
have strictf: "strict_mono_on f {0..<n}" and strictg: "strict_mono_on g {0..<n}"
using f g unfolding F_strict_def by auto
have "f x = (sorted_list_of_set (f`{0..<n})) ! x" by (rule nth_strict_mono_on[OF strictf True])
also have "... = (sorted_list_of_set (g`{0..<n})) ! x" unfolding fg by simp
also have "... = g x" by (rule nth_strict_mono_on[symmetric, OF strictg True])
finally show ?thesis .
next
case False
then show ?thesis using f g unfolding F_strict_def by auto
qed
qed
lemma strict_from_inj_preserves_F:
assumes f: "f ∈ F_inj"
shows "strict_from_inj n f ∈ F"
proof -
{
fix x assume x: "x < n"
have inj_on: "inj_on f {0..<n}" using f unfolding F_inj_def by auto
have "{a. a < m ∧ a ∈ f ` {0..<n}} = f`{0..<n}" using f unfolding F_inj_def by auto
hence card_eq: "card {a. a < m ∧ a ∈ f ` {0..<n}} = n"
by (simp add: card_image inj_on)
let ?I = "f`{0..<n}"
have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
by (metis distinct_card finite_atLeastLessThan finite_imageI
sorted_list_of_set(1) sorted_list_of_set(3))
also have "... = n"
by (simp add: card_image strict_mono_imp_inj_on inj_on)
finally have length_I: "length (sorted_list_of_set ?I) = n" .
have "sorted_list_of_set (f ` {0..<n}) ! x = pick (f ` {0..<n}) x"
by (rule sorted_list_of_set_eq_pick, unfold length_I, auto simp add: x)
also have "... < m" by (rule pick_le, unfold card_eq, rule x)
finally have "sorted_list_of_set (f ` {0..<n}) ! x < m" .
}
thus ?thesis unfolding strict_from_inj_def F_def by auto
qed
lemma strict_from_inj_F_strict: "strict_from_inj n xa ∈ F_strict"
if xa: "xa ∈ F_inj" for xa
proof -
have "strict_mono_on (strict_from_inj n xa) {0..<n}"
by (rule strict_strict_from_inj, insert xa, simp add: F_inj_def)
thus ?thesis using strict_from_inj_preserves_F[OF xa] unfolding F_def F_strict_def by auto
qed
lemma strict_from_inj_image:
assumes f: "f∈ F_inj"
shows "strict_from_inj n f ` {0..<n} = f`{0..<n}"
proof (auto)
let ?I = "f ` {0..<n}"
fix xa assume xa: "xa < n"
have inj_on: "inj_on f {0..<n}" using f unfolding F_inj_def by auto
have "{a. a < m ∧ a ∈ f ` {0..<n}} = f`{0..<n}" using f unfolding F_inj_def by auto
hence card_eq: "card {a. a < m ∧ a ∈ f ` {0..<n}} = n"
by (simp add: card_image inj_on)
let ?I = "f`{0..<n}"
have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
by (metis distinct_card finite_atLeastLessThan finite_imageI
sorted_list_of_set(1) sorted_list_of_set(3))
also have "... = n"
by (simp add: card_image strict_mono_imp_inj_on inj_on)
finally have length_I: "length (sorted_list_of_set ?I) = n" .
have "strict_from_inj n f xa = sorted_list_of_set ?I ! xa"
using xa unfolding strict_from_inj_def by auto
also have "... = pick ?I xa"
by (rule sorted_list_of_set_eq_pick, unfold length_I, auto simp add: xa)
also have "... ∈ f ` {0..<n}" by (rule pick_in_set_le, simp add: ‹card (f ` {0..<n}) = n› xa)
finally show "strict_from_inj n f xa ∈ f ` {0..<n}" .
obtain i where "sorted_list_of_set (f`{0..<n}) ! i = f xa" and "i<n"
by (metis atLeast0LessThan finite_atLeastLessThan finite_imageI imageI
in_set_conv_nth length_I lessThan_iff sorted_list_of_set(1) xa)
thus "f xa ∈ strict_from_inj n f ` {0..<n}"
by (metis atLeast0LessThan imageI lessThan_iff strict_from_inj_def)
qed
lemma Z_good_alt:
assumes g: "g ∈ F_strict"
shows "Z_good g = {x ∈ F_inj. strict_from_inj n x = g} × {π. π permutes {0..<n}}"
proof -
define Z_good_fun where "Z_good_fun = {f. f ∈ {0..<n} → {0..<m} ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)
∧ inj_on f {0..<n} ∧ (f`{0..<n} = g`{0..<n})}"
have "Z_good_fun = {x ∈ F_inj. strict_from_inj n x = g}"
proof (auto)
fix f assume f: "f ∈ Z_good_fun" thus f_inj: "f ∈ F_inj" unfolding F_inj_def Z_good_fun_def by auto
show "strict_from_inj n f = g"
proof (rule strict_fun_eq[OF _ g])
show "strict_from_inj n f ` {0..<n} = g ` {0..<n}"
using f_inj f strict_from_inj_image
unfolding Z_good_fun_def F_inj_def by auto
show "strict_from_inj n f ∈ F_strict"
using F_strict_def f_inj strict_from_inj_F_strict by blast
qed
next
fix f assume f_inj: "f ∈ F_inj" and g_strict_f: "g = strict_from_inj n f"
have "f xa ∈ g ` {0..<n}" if "xa < n" for xa
using f_inj g_strict_f strict_from_inj_image that by auto
moreover have "g xa ∈ f ` {0..<n}" if "xa < n" for xa
by (metis f_inj g_strict_f imageI lessThan_atLeast0 lessThan_iff strict_from_inj_image that)
ultimately show "f ∈ Z_good_fun"
using f_inj g_strict_f unfolding Z_good_fun_def F_inj_def
by auto
qed
thus ?thesis unfolding Z_good_fun_def Z_good_def by simp
qed
lemma weight_0: "(∑(f, π) ∈ Z_not_inj. weight f π) = 0"
proof -
let ?F="{f. (∀i∈{0..<n}. f i ∈ {0..<m}) ∧ (∀i. i ∉ {0..<n} ⟶ f i = i)}"
let ?Perm = "{π. π permutes {0..<n}}"
have "(∑(f, π)∈Z_not_inj. weight f π)
= (∑f ∈ F_not_inj. (∏i = 0..<n. A $$ (i, f i)) * det (mat⇩r n n (λi. row B (f i))))"
proof -
have dim_row_rw: "dim_row (mat⇩r n n (λi. col A (f i))) = n" for f by auto
have dim_row_rw2: "dim_row (mat⇩r n n (λi. Matrix.row B (f i))) = n" for f by auto
have prod_rw: "(∏i = 0..<n. B $$ (f i, π i)) = (∏i = 0..<n. row B (f i) $v π i)"
if f: "f ∈ F_not_inj" and pi: "π ∈ ?Perm" for f π
proof (rule prod.cong, rule refl)
fix x assume x: "x ∈ {0..<n}"
have "f x < dim_row B" using f B x unfolding F_not_inj_def by fastforce
moreover have "π x < dim_col B" using x pi B by auto
ultimately show "B $$ (f x, π x) = Matrix.row B (f x) $v π x" by (rule index_row[symmetric])
qed
have sum_rw: "(∑π | π permutes {0..<n}. signof π * (∏i = 0..<n. B $$ (f i, π i)))
= det (mat⇩r n n (λi. row B (f i)))" if f: "f ∈ F_not_inj" for f
unfolding Determinant.det_def using dim_row_rw2 prod_rw f by auto
have "(∑(f, π)∈Z_not_inj. weight f π) = (∑f∈F_not_inj.∑π ∈ ?Perm. weight f π)"
unfolding Z_not_inj_def unfolding sum.cartesian_product
unfolding F_not_inj_def by simp
also have "... = (∑f∈F_not_inj. ∑π | π permutes {0..<n}. signof π
* (∏i = 0..<n. A $$ (i, f i) * B $$ (f i, π i)))"
unfolding weight_def by simp
also have "... = (∑f∈F_not_inj. (∏i = 0..<n. A $$ (i, f i))
* (∑π | π permutes {0..<n}. signof π * (∏i = 0..<n. B $$ (f i, π i))))"
by (rule sum.cong, rule refl, auto)
(metis (no_types, lifting) mult.left_commute mult_hom.hom_sum sum.cong)
also have "... = (∑f ∈ F_not_inj. (∏i = 0..<n. A $$ (i, f i))
* det (mat⇩r n n (λi. row B (f i))))" using sum_rw by auto
finally show ?thesis by auto
qed
also have "... = 0"
by (rule sum.neutral, insert det_not_inj_on[of _ n B], auto simp add: F_not_inj_def)
finally show ?thesis .
qed
subsection ‹Final theorem›
lemma Cauchy_Binet1:
shows "det (A*B) =
sum (λf. det (submatrix A UNIV (f`{0..<n})) * det (submatrix B (f`{0..<n}) UNIV)) F_strict"
(is "?lhs = ?rhs")
proof -
have sum0: "(∑(f, π) ∈ Z_not_inj. weight f π) = 0" by (rule weight_0)
let ?f = "strict_from_inj n"
have sum_rw: "sum g F_inj = (∑y ∈ F_strict. sum g {x ∈ F_inj. ?f x = y})" for g
by (rule sum.group[symmetric], insert strict_from_inj_F_strict, auto)
have Z_Union: "Z_inj ∪ Z_not_inj = Z n m"
unfolding Z_def Z_not_inj_def Z_inj_def by auto
have Z_Inter: "Z_inj ∩ Z_not_inj = {}"
unfolding Z_def Z_not_inj_def Z_inj_def by auto
have "det (A*B) = (∑(f, π)∈Z n m. weight f π)"
using detAB_Znm[OF A B] unfolding weight_def by auto
also have "... = (∑(f, π)∈Z_inj. weight f π) + (∑(f, π)∈Z_not_inj. weight f π)"
by (metis Z_Inter Z_Union finite_Un finite_Znm sum.union_disjoint)
also have "... = (∑(f, π)∈Z_inj. weight f π)" using sum0 by force
also have "... = (∑f ∈ F_inj. ∑π∈{π. π permutes {0..<n}}. weight f π)"
unfolding Z_inj_def unfolding F_inj_def sum.cartesian_product ..
also have "... = (∑y∈F_strict. ∑f∈{x ∈ F_inj. strict_from_inj n x = y}.
sum (weight f) {π. π permutes {0..<n}})" unfolding sum_rw ..
also have "... = (∑y∈F_strict. ∑(f,π)∈({x ∈ F_inj. strict_from_inj n x = y}
× {π. π permutes {0..<n}}). weight f π)"
unfolding F_inj_def sum.cartesian_product ..
also have "... = sum (λg. sum (λ(f,π). weight f π) (Z_good g)) F_strict"
using Z_good_alt by auto
also have "... = ?rhs" unfolding gather_by_strictness by simp
finally show ?thesis .
qed
lemma Cauchy_Binet:
"det (A*B) = (∑I∈{I. I⊆{0..<m} ∧ card I=n}. det (submatrix A UNIV I) * det (submatrix B I UNIV))"
proof -
let ?f="(λI. (λi. if i<n then sorted_list_of_set I ! i else i))"
let ?setI = "{I. I ⊆ {0..<m} ∧ card I = n}"
have inj_on: "inj_on ?f ?setI"
proof (rule inj_onI)
fix I J assume I: "I ∈ ?setI" and J: "J ∈ ?setI" and fI_fJ: "?f I = ?f J"
have "x ∈ J" if x: "x ∈ I" for x
by (metis (mono_tags) fI_fJ I J distinct_card in_set_conv_nth mem_Collect_eq
sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite x)
moreover have "x ∈ I" if x: "x ∈ J" for x
by (metis (mono_tags) fI_fJ I J distinct_card in_set_conv_nth mem_Collect_eq
sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite x)
ultimately show "I = J" by auto
qed
have rw: "?f I ` {0..<n} = I" if I: "I ∈ ?setI" for I
proof -
have "sorted_list_of_set I ! xa ∈ I" if "xa < n" for xa
by (metis (mono_tags, lifting) I distinct_card distinct_sorted_list_of_set mem_Collect_eq
nth_mem set_sorted_list_of_set subset_eq_atLeast0_lessThan_finite that)
moreover have "∃xa∈{0..<n}. x = sorted_list_of_set I ! xa" if x: "x∈I" for x
by (metis (full_types) x I atLeast0LessThan distinct_card in_set_conv_nth mem_Collect_eq
lessThan_iff sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite)
ultimately show ?thesis unfolding image_def by auto
qed
have f_setI: "?f` ?setI = F_strict"
proof -
have "sorted_list_of_set I ! xa < m" if I: "I ⊆ {0..<m}" and "n = card I" and "xa < card I"
for I xa
by (metis I ‹xa < card I› atLeast0LessThan distinct_card finite_atLeastLessThan lessThan_iff
pick_in_set_le rev_finite_subset sorted_list_of_set(1)
sorted_list_of_set(3) sorted_list_of_set_eq_pick subsetCE)
moreover have "strict_mono_on (λi. if i < card I then sorted_list_of_set I ! i else i) {0..<card I}"
if "I ⊆ {0..<m}" and "n = card I" for I
by (smt ‹I ⊆ {0..<m}› atLeastLessThan_iff distinct_card finite_atLeastLessThan pick_mono_le
rev_finite_subset sorted_list_of_set(1) sorted_list_of_set(3)
sorted_list_of_set_eq_pick strict_mono_on_def)
moreover have "x ∈ ?f ` {I. I ⊆ {0..<m} ∧ card I = n}"
if x1: "x ∈ {0..<n} → {0..<m}" and x2: "∀i. ¬ i < n ⟶ x i = i"
and s: "strict_mono_on x {0..<n}" for x
proof -
have inj_x: "inj_on x {0..<n}"
using s strict_mono_on_imp_inj_on by blast
hence card_xn: "card (x ` {0..<n}) = n" by (simp add: card_image)
have x_eq: "x = (λi. if i < n then sorted_list_of_set (x ` {0..<n}) ! i else i)"
unfolding fun_eq_iff
using nth_strict_mono_on s using x2 by auto
show ?thesis
unfolding image_def by (auto, rule exI[of _"x`{0..<n}"], insert card_xn x1 x_eq, auto)
qed
ultimately show ?thesis unfolding F_strict_def by auto
qed
let ?g = "(λf. det (submatrix A UNIV (f`{0..<n})) * det(submatrix B (f`{0..<n}) UNIV))"
have "det (A*B) = sum ((λf. det (submatrix A UNIV (f ` {0..<n}))
* det (submatrix B (f ` {0..<n}) UNIV)) ∘ ?f) {I. I ⊆ {0..<m} ∧ card I = n}"
unfolding Cauchy_Binet1 f_setI[symmetric] by (rule sum.reindex[OF inj_on])
also have "... = (∑I∈{I. I⊆{0..<m} ∧ card I=n}.det(submatrix A UNIV I)*det(submatrix B I UNIV))"
by (rule sum.cong, insert rw, auto)
finally show ?thesis .
qed
end
end
Theory Rings2_Extended
section ‹Some theorems about rings and ideals›
theory Rings2_Extended
imports
Echelon_Form.Rings2
"HOL-Types_To_Sets.Types_To_Sets"
begin
subsection ‹Missing properties on ideals›
lemma ideal_generated_subset2:
assumes "∀b∈B. b ∈ ideal_generated A"
shows "ideal_generated B ⊆ ideal_generated A"
by (metis (mono_tags, lifting) InterE assms ideal_generated_def
ideal_ideal_generated mem_Collect_eq subsetI)
context comm_ring_1
begin
lemma ideal_explicit: "ideal_generated S
= {y. ∃f U. finite U ∧ U ⊆ S ∧ (∑i∈U. f i * i) = y}"
by (simp add: ideal_generated_eq_left_ideal left_ideal_explicit)
end
lemma ideal_generated_minus:
assumes a: "a ∈ ideal_generated (S-{a})"
shows "ideal_generated S = ideal_generated (S-{a})"
proof (cases "a ∈ S")
case True note a_in_S = True
show ?thesis
proof
show "ideal_generated S ⊆ ideal_generated (S - {a})"
proof (rule ideal_generated_subset2, auto)
fix b assume b: "b ∈ S" show "b ∈ ideal_generated (S - {a})"
proof (cases "b = a")
case True
then show ?thesis using a by auto
next
case False
then show ?thesis using b
by (simp add: ideal_generated_in)
qed
qed
show "ideal_generated (S - {a}) ⊆ ideal_generated S"
by (rule ideal_generated_subset, auto)
qed
next
case False
then show ?thesis by simp
qed
lemma ideal_generated_dvd_eq:
assumes a_dvd_b: "a dvd b"
and a: "a ∈ S"
and a_not_b: "a ≠ b"
shows "ideal_generated S = ideal_generated (S - {b})"
proof
show "ideal_generated S ⊆ ideal_generated (S - {b})"
proof (rule ideal_generated_subset2, auto)
fix x assume x: "x ∈ S"
show "x ∈ ideal_generated (S - {b})"
proof (cases "x = b")
case True
obtain k where b_ak: "b = a * k" using a_dvd_b unfolding dvd_def by blast
let ?f = "λc. k"
have "(∑i∈{a}. i * ?f i) = x" using True b_ak by auto
moreover have "{a} ⊆ S - {b}" using a_not_b a by auto
moreover have "finite {a}" by auto
ultimately show ?thesis
unfolding ideal_def
by (metis True b_ak ideal_def ideal_generated_in ideal_ideal_generated insert_subset right_ideal_def)
next
case False
then show ?thesis by (simp add: ideal_generated_in x)
qed
qed
show "ideal_generated (S - {b}) ⊆ ideal_generated S" by (rule ideal_generated_subset, auto)
qed
lemma ideal_generated_dvd_eq_diff_set:
assumes i_in_I: "i∈I" and i_in_J: "i ∉ J" and i_dvd_j: "∀j∈J. i dvd j"
and f: "finite J"
shows "ideal_generated I = ideal_generated (I - J)"
using f i_in_J i_dvd_j i_in_I
proof (induct J arbitrary: I)
case empty
then show ?case by auto
next
case (insert x J)
have "ideal_generated I = ideal_generated (I-{x})"
by (rule ideal_generated_dvd_eq[of i], insert insert.prems , auto)
also have "... = ideal_generated ((I-{x}) - J)"
by (rule insert.hyps, insert insert.prems insert.hyps, auto)
also have "... = ideal_generated (I - insert x J)"
using Diff_insert2[of I x J] by auto
finally show ?case .
qed
context comm_ring_1
begin
lemma ideal_generated_singleton_subset:
assumes d: "d ∈ ideal_generated S" and fin_S: "finite S"
shows "ideal_generated {d} ⊆ ideal_generated S"
proof
fix x assume x: "x ∈ ideal_generated {d}"
obtain k where x_kd: "x = k*d " using x using obtain_sum_ideal_generated[OF x]
by (metis finite.emptyI finite.insertI sum_singleton)
show "x ∈ ideal_generated S"
using d ideal_eq_right_ideal ideal_ideal_generated right_ideal_def mult_commute x_kd by auto
qed
lemma ideal_generated_singleton_dvd:
assumes i: "ideal_generated S = ideal_generated {d}" and x: "x ∈ S"
shows "d dvd x"
by (metis i x finite.intros dvd_ideal_generated_singleton
ideal_generated_in ideal_generated_singleton_subset)
lemma ideal_generated_UNIV_insert:
assumes "ideal_generated S = UNIV"
shows "ideal_generated (insert a S) = UNIV" using assms
using local.ideal_generated_subset by blast
lemma ideal_generated_UNIV_union:
assumes "ideal_generated S = UNIV"
shows "ideal_generated (A ∪ S) = UNIV"
using assms local.ideal_generated_subset
by (metis UNIV_I Un_subset_iff equalityI subsetI)
lemma ideal_explicit2:
assumes "finite S"
shows "ideal_generated S = {y. ∃f. (∑i∈S. f i * i) = y}"
by (smt Collect_cong assms ideal_explicit obtain_sum_ideal_generated mem_Collect_eq subsetI)
lemma ideal_generated_unit:
assumes u: "u dvd 1"
shows "ideal_generated {u} = UNIV"
proof -
have "x ∈ ideal_generated {u}" for x
proof -
obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
using local.mult_ac(2) by blast
have "x = x * inv_u * u" using inv_u by (simp add: local.mult_ac(1))
also have "... ∈ {k * u |k. k ∈ UNIV}" by auto
also have "... = ideal_generated {u}" unfolding ideal_generated_singleton by simp
finally show ?thesis .
qed
thus ?thesis by auto
qed
lemma ideal_generated_dvd_subset:
assumes x: "∀x ∈ S. d dvd x" and S: "finite S"
shows "ideal_generated S ⊆ ideal_generated {d}"
proof
fix x assume "x∈ ideal_generated S"
from this obtain f where f: "(∑i∈S. f i * i) = x" using ideal_explicit2[OF S] by auto
have "d dvd (∑i∈S. f i * i)" by (rule dvd_sum, insert x, auto)
thus "x ∈ ideal_generated {d}"
using f dvd_ideal_generated_singleton' ideal_generated_in singletonI by blast
qed
lemma ideal_generated_mult_unit:
assumes f: "finite S" and u: "u dvd 1"
shows "ideal_generated ((λx. u*x)` S) = ideal_generated S"
using f
proof (induct S)
case empty
then show ?case by auto
next
case (insert x S)
obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
using mult_ac by blast
have f: "finite (insert (u*x) ((λx. u*x)` S))" using insert.hyps by auto
have f2: "finite (insert x S)" by (simp add: insert(1))
have f3: "finite S" by (simp add: insert)
have f4: "finite ((*) u ` S)" by (simp add: insert)
have inj_ux: "inj_on (λx. u*x) S" unfolding inj_on_def
by (auto, metis inv_u local.mult_1_left local.semiring_normalization_rules(18))
have "ideal_generated ((λx. u*x)` (insert x S)) = ideal_generated (insert (u*x) ((λx. u*x)` S))"
by auto
also have "... = {y. ∃f. (∑i∈insert (u*x) ((λx. u*x)` S). f i * i) = y}"
using ideal_explicit2[OF f] by auto
also have "... = {y. ∃f. (∑i∈(insert x S). f i * i) = y}" (is "?L = ?R")
proof -
have "a ∈ ?L" if a: "a ∈ ?R" for a
proof -
obtain f where sum_rw: "(∑i∈(insert x S). f i * i) = a" using a by auto
define b where "b=(∑i∈S. f i * i)"
have "b ∈ ideal_generated S" unfolding b_def ideal_explicit2[OF f3] by auto
hence "b ∈ ideal_generated ((*) u ` S)" using insert.hyps(3) by auto
from this obtain g where "(∑i∈((*) u ` S). g i * i) = b"
unfolding ideal_explicit2[OF f4] by auto
hence sum_rw2: "(∑i∈S. f i * i) = (∑i∈((*) u ` S). g i * i)" unfolding b_def by auto
let ?g = "λi. if i = u*x then f x * inv_u else g i"
have sum_rw3: "sum ((λi. g i * i) ∘ (λx. u*x)) S = sum ((λi. ?g i * i) ∘ (λx. u*x)) S"
by (rule sum.cong, auto, metis inv_u local.insert(2) local.mult_1_right
local.mult_ac(2) local.semiring_normalization_rules(18))
have sum_rw4: "(∑i∈(λx. u*x)` S. g i * i) = sum ((λi. g i * i) ∘ (λx. u*x)) S"
by (rule sum.reindex[OF inj_ux])
have "a = f x * x + (∑i∈S. f i * i)"
using sum_rw local.insert(1) local.insert(2) by auto
also have "... = f x * x + (∑i∈(λx. u*x)` S. g i * i)" using sum_rw2 by auto
also have "... = ?g (u * x) * (u * x) + (∑i∈(λx. u*x)` S. g i * i)"
using inv_u by (smt local.mult_1_right local.mult_ac(1))
also have "... = ?g (u * x) * (u * x) + sum ((λi. g i * i) ∘ (λx. u*x)) S"
using sum_rw4 by auto
also have "... = ((λi. ?g i * i) ∘ (λx. u*x)) x + sum ((λi. g i * i) ∘ (λx. u*x)) S" by auto
also have "... = ((λi. ?g i * i) ∘ (λx. u*x)) x + sum ((λi. ?g i * i) ∘ (λx. u*x)) S"
using sum_rw3 by auto
also have "... = sum ((λi. ?g i * i) ∘ (λx. u*x)) (insert x S)"
by (rule sum.insert[symmetric], auto simp add: insert)
also have "... = (∑i∈insert (u * x) ((λx. u*x)` S). ?g i * i)"
by (smt abel_semigroup.commute f2 image_insert inv_u mult.abel_semigroup_axioms mult_1_right
semiring_normalization_rules(18) sum.reindex_nontrivial)
also have "... = (∑i∈(λx. u*x)` (insert x S). ?g i * i)" by auto
finally show ?thesis by auto
qed
moreover have "a ∈ ?R" if a: "a ∈ ?L" for a
proof -
obtain f where sum_rw: "(∑i∈(insert (u * x) ((*) u ` S)). f i * i) = a" using a by auto
have ux_notin: "u*x ∉ ((*) u ` S)"
by (metis UNIV_I inj_on_image_mem_iff inj_on_inverseI inv_u local.insert(2) local.mult_1_left
local.semiring_normalization_rules(18) subsetI)
let ?f = "(λx. f x * x)"
have "sum ?f ((*) u ` S) ∈ ideal_generated ((*) u ` S)"
unfolding ideal_explicit2[OF f4] by auto
from this obtain g where sum_rw1: "sum (λi. g i * i) S = sum ?f (((*) u ` S))"
using insert.hyps(3) unfolding ideal_explicit2[OF f3] by blast
let ?g = "(λi. if i = x then (f (u*x) *u) * x else g i * i)"
let ?g' = "λi. if i = x then f (u*x) * u else g i"
have sum_rw2: "sum (λi. g i * i) S = sum ?g S" by (rule sum.cong, insert inj_ux ux_notin, auto)
have "a = (∑i∈(insert (u * x) ((*) u ` S)). f i * i)" using sum_rw by simp
also have "... = ?f (u*x) + sum ?f (((*) u ` S))"
by (rule sum.insert[OF f4], insert inj_ux) (metis UNIV_I inj_on_image_mem_iff inj_on_inverseI
inv_u local.insert(2) local.mult_1_left local.semiring_normalization_rules(18) subsetI)
also have "... = ?f (u*x) + sum (λi. g i * i) S" unfolding sum_rw1 by auto
also have "... = ?g x + sum ?g S" unfolding sum_rw2 using mult.assoc by auto
also have "... = sum ?g (insert x S)" by (rule sum.insert[symmetric, OF f3 insert.hyps(2)])
also have "... = sum (λi. ?g' i * i) (insert x S)" by (rule sum.cong, auto)
finally show ?thesis by fast
qed
ultimately show ?thesis by blast
qed
also have "... = ideal_generated (insert x S)" using ideal_explicit2[OF f2] by auto
finally show ?case by auto
qed
corollary ideal_generated_mult_unit2:
assumes u: "u dvd 1"
shows "ideal_generated {u*a,u*b} = ideal_generated {a,b}"
proof -
let ?S = "{a,b}"
have "ideal_generated {u*a,u*b} = ideal_generated ((λx. u*x)` {a,b})" by auto
also have "... = ideal_generated {a,b}" by (rule ideal_generated_mult_unit[OF _ u], simp)
finally show ?thesis .
qed
lemma ideal_generated_1[simp]: "ideal_generated {1} = UNIV"
by (metis ideal_generated_unit dvd_ideal_generated_singleton order_refl)
lemma ideal_generated_pair: "ideal_generated {a,b} = {p*a+q*b | p q. True}"
proof -
have i: "ideal_generated {a,b} = {y. ∃f. (∑i∈{a,b}. f i * i) = y}" using ideal_explicit2 by auto
show ?thesis
proof (cases "a=b")
case True
show ?thesis using True i
by (auto, metis mult_ac(2) semiring_normalization_rules)
(metis (no_types, hide_lams) add_minus_cancel mult_ac ring_distribs semiring_normalization_rules)
next
case False
have 1: "∃p q. (∑i∈{a, b}. f i * i) = p * a + q * b" for f
by (rule exI[of _ "f a"], rule exI[of _ "f b"], rule sum_two_elements[OF False])
moreover have "∃f. (∑i∈{a, b}. f i * i) = p * a + q * b" for p q
by (rule exI[of _ "λi. if i=a then p else q"],
unfold sum_two_elements[OF False], insert False, auto)
ultimately show ?thesis using i by auto
qed
qed
lemma ideal_generated_pair_exists_pq1:
assumes i: "ideal_generated {a,b} = (UNIV::'a set)"
shows "∃p q. p*a + q*b = 1"
using i unfolding ideal_generated_pair
by (smt iso_tuple_UNIV_I mem_Collect_eq)
lemma ideal_generated_pair_UNIV:
assumes sa_tb_u: "s*a+t*b = u" and u: "u dvd 1"
shows "ideal_generated {a,b} = UNIV"
proof -
have f: "finite {a,b}" by simp
obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
by (metis mult.commute)
have "x ∈ ideal_generated {a,b}" for x
proof (cases "a = b")
case True
then show ?thesis
by (metis UNIV_I dvd_def dvd_ideal_generated_singleton' ideal_generated_unit insert_absorb2
mult.commute sa_tb_u semiring_normalization_rules(34) subsetI subset_antisym u)
next
case False note a_not_b = False
let ?f = "λy. if y = a then inv_u * x * s else inv_u * x * t"
have "(∑i∈{a,b}. ?f i * i) = ?f a * a + ?f b * b" by (rule sum_two_elements[OF a_not_b])
also have "... = x" using a_not_b sa_tb_u inv_u
by (auto, metis mult_ac(1) mult_ac(2) ring_distribs(1) semiring_normalization_rules(12))
finally show ?thesis unfolding ideal_explicit2[OF f] by auto
qed
thus ?thesis by auto
qed
lemma ideal_generated_pair_exists:
assumes l: "(ideal_generated {a,b} = ideal_generated {d})"
shows "(∃ p q. p*a+q*b = d)"
proof -
have d: "d ∈ ideal_generated {d}" by (simp add: ideal_generated_in)
hence "d ∈ ideal_generated {a,b}" using l by auto
from this obtain p q where "d = p*a+q*b" using ideal_generated_pair[of a b] by auto
thus ?thesis by auto
qed
lemma obtain_ideal_generated_pair:
assumes "c ∈ ideal_generated {a,b}"
obtains p q where "p*a+q*b=c"
proof -
have "c ∈ {p * a + q * b |p q. True}" using assms ideal_generated_pair by auto
thus ?thesis using that by auto
qed
lemma ideal_generated_pair_exists_UNIV:
shows "(ideal_generated {a,b} = ideal_generated {1}) = (∃p q. p*a+q*b = 1)" (is "?lhs = ?rhs")
proof
assume r: ?rhs
have "x ∈ ideal_generated {a,b}" for x
proof (cases "a=b")
case True
then show ?thesis
by (metis UNIV_I r dvd_ideal_generated_singleton finite.intros ideal_generated_1
ideal_generated_pair_UNIV ideal_generated_singleton_subset)
next
case False
have f: "finite {a,b}" by simp
have 1: "1 ∈ ideal_generated {a,b}"
using ideal_generated_pair_UNIV local.one_dvd r by blast
hence i: "ideal_generated {a,b} = {y. ∃f. (∑i∈{a,b}. f i * i) = y}"
using ideal_explicit2[of "{a,b}"] by auto
from this obtain f where f: "f a * a + f b * b = 1" using sum_two_elements 1 False by auto
let ?f = "λy. if y = a then x * f a else x * f b"
have "(∑i∈{a,b}. ?f i * i) = x" unfolding sum_two_elements[OF False] using f False
using mult_ac(1) ring_distribs(1) semiring_normalization_rules(12) by force
thus ?thesis unfolding i by auto
qed
thus ?lhs by auto
next
assume ?lhs thus ?rhs using ideal_generated_pair_exists[of a b 1] by auto
qed
corollary ideal_generated_UNIV_obtain_pair:
assumes "ideal_generated {a,b} = ideal_generated {1}"
shows " (∃p q. p*a+q*b = d)"
proof -
obtain x y where "x*a+y*b = 1" using ideal_generated_pair_exists_UNIV assms by auto
hence "d*x*a+d*y*b=d"
using local.mult_ac(1) local.ring_distribs(1) local.semiring_normalization_rules(12) by force
thus ?thesis by auto
qed
lemma sum_three_elements:
shows "∃x y z::'a. (∑i∈{a,b,c}. f i * i) = x * a + y * b + z * c"
proof (cases "a ≠ b ∧ b ≠ c ∧ a ≠ c")
case True
then show ?thesis by (auto, metis add.assoc)
next
case False
have 1: "∃x y z. f c * c = x * c + y * c + z * c"
by (rule exI[of _ 0],rule exI[of _ 0], rule exI[of _ "f c"], auto)
have 2: "∃x y z. f b * b + f c * c = x * b + y * b + z * c"
by (rule exI[of _ 0],rule exI[of _ "f b"], rule exI[of _ "f c"], auto)
have 3: "∃x y z. f a * a + f c * c = x * a + y * c + z * c"
by (rule exI[of _ "f a"],rule exI[of _ 0], rule exI[of _ "f c"], auto)
have 4: "∃x y z. (∑i∈{c, b, c}. f i * i) = x * c + y * b + z * c" if a: "a = c" and b: "b ≠ c"
by (rule exI[of _ 0],rule exI[of _ "f b"], rule exI[of _ "f c"], insert a b,
auto simp add: insert_commute)
show ?thesis using False
by (cases "b=c", cases "a=c", auto simp add: 1 2 3 4)
qed
lemma sum_three_elements':
shows "∃f::'a⇒'a. (∑i∈{a,b,c}. f i * i) = x * a + y * b + z * c"
proof (cases "a ≠ b ∧ b ≠ c ∧ a ≠ c")
case True
let ?f = "λi. if i = a then x else if i = b then y else if i = c then z else 0"
show ?thesis by (rule exI[of _ "?f"], insert True mult.assoc, auto simp add: local.add_ac)
next
case False
have 1: "∃f. f c * c = x * c + y * c + z * c"
by (rule exI[of _ "λi. if i = c then x+y+z else 0"], auto simp add: local.ring_distribs)
have 2: "∃f. f a * a + f c * c = x * a + y * c + z * c" if bc: " b = c" and ac: "a ≠ c"
by (rule exI[of _ "λi. if i = a then x else y+z"], insert ac bc add_ac ring_distribs, auto)
have 3: "∃f. f b * b + f c * c = x * b + y * b + z * c" if bc: " b ≠ c" and ac: "a = b"
by (rule exI[of _ "λi. if i = a then x+y else z"], insert ac bc add_ac ring_distribs, auto)
have 4: "∃f. (∑i∈{c, b, c}. f i * i) = x * c + y * b + z * c" if a: "a = c" and b: "b ≠ c"
by (rule exI[of _ "λi. if i = c then x+z else y"], insert a b add_ac ring_distribs,
auto simp add: insert_commute)
show ?thesis using False
by (cases "b=c", cases "a=c", auto simp add: 1 2 3 4)
qed
lemma ideal_generated_triple_pair_rewrite:
assumes i1: "ideal_generated {a, b, c} = ideal_generated {d}"
and i2: "ideal_generated {a, b} = ideal_generated {d'}"
shows "ideal_generated{d',c} = ideal_generated {d}"
proof
have d': "d' ∈ ideal_generated {a,b}" using i2 by (simp add: ideal_generated_in)
show "ideal_generated {d', c} ⊆ ideal_generated {d}"
proof
fix x assume x: "x ∈ ideal_generated {d', c}"
obtain f1 f2 where f: "f1*d' + f2*c = x" using obtain_ideal_generated_pair[OF x] by auto
obtain g1 g2 where g: "g1*a + g2*b = d'" using obtain_ideal_generated_pair[OF d'] by blast
have 1: "f1*g1*a + f1*g2*b + f2*c = x"
using f g local.ring_distribs(1) local.semiring_normalization_rules(18) by auto
have "x ∈ ideal_generated {a, b, c}"
proof -
obtain f where "(∑i∈{a,b,c}. f i * i) = f1*g1*a + f1*g2*b + f2*c"
using sum_three_elements' 1 by blast
moreover have "ideal_generated {a,b,c} = {y. ∃f. (∑i∈{a,b,c}. f i * i) = y}"
using ideal_explicit2[of "{a,b,c}"] by simp
ultimately show ?thesis using 1 by auto
qed
thus "x ∈ ideal_generated {d}" using i1 by auto
qed
show "ideal_generated {d} ⊆ ideal_generated {d', c}"
proof (rule ideal_generated_singleton_subset)
obtain f1 f2 f3 where f: "f1*a + f2*b + f3*c = d"
proof -
have "d ∈ ideal_generated {a,b,c}" using i1 by (simp add: ideal_generated_in)
from this obtain f where d: "(∑i∈{a,b,c}. f i * i) = d"
using ideal_explicit2[of "{a,b,c}"] by auto
obtain x y z where "(∑i∈{a,b,c}. f i * i) = x * a + y * b + z * c"
using sum_three_elements by blast
thus ?thesis using d that by auto
qed
obtain k where k: "f1*a + f2*b = k*d'"
proof -
have "f1*a + f2*b ∈ ideal_generated{a,b}" using ideal_generated_pair by blast
also have "... = ideal_generated {d'}" using i2 by simp
also have "... = {k*d' |k. k∈UNIV}" using ideal_generated_singleton by auto
finally show ?thesis using that by auto
qed
have "k*d'+f3*c=d" using f k by auto
thus "d ∈ ideal_generated {d', c}"
using ideal_generated_pair by blast
qed (simp)
qed
lemma ideal_generated_dvd:
assumes i: "ideal_generated {a,b::'a} = ideal_generated{d} "
and a: "d' dvd a" and b: "d' dvd b"
shows "d' dvd d"
proof -
obtain p q where "p*a+q*b = d"
using i ideal_generated_pair_exists by blast
thus ?thesis using a b by auto
qed
lemma ideal_generated_dvd2:
assumes i: "ideal_generated S = ideal_generated{d::'a} "
and "finite S"
and x: "∀x∈S. d' dvd x"
shows "d' dvd d"
by (metis assms dvd_ideal_generated_singleton ideal_generated_dvd_subset)
end
subsection ‹An equivalent characterization of B\'ezout rings›
text ‹The goal of this subsection is to prove that a ring is B\'ezout ring if and only if every
finitely generated ideal is principal.›
definition "finitely_generated_ideal I = (ideal I ∧ (∃S. finite S ∧ ideal_generated S = I))"
context
assumes "SORT_CONSTRAINT('a::comm_ring_1)"
begin
lemma sum_two_elements':
fixes d::'a
assumes s: "(∑i∈{a,b}. f i * i) = d"
obtains p and q where "d = p * a + q * b"
proof (cases "a=b")
case True
then show ?thesis
by (metis (no_types, lifting) add_diff_cancel_left' emptyE finite.emptyI insert_absorb2
left_diff_distrib' s sum.insert sum_singleton that)
next
case False
show ?thesis using s unfolding sum_two_elements[OF False]
using that by auto
qed
text ‹This proof follows Theorem 6-3 in "First Course in Rings and Ideals" by Burton›
lemma all_fin_gen_ideals_are_principal_imp_bezout:
assumes all: "∀I::'a set. finitely_generated_ideal I ⟶ principal_ideal I"
shows "OFCLASS ('a, bezout_ring_class)"
proof (intro_classes)
fix a b::'a
obtain d where ideal_d: "ideal_generated {a,b} = ideal_generated {d}"
using all unfolding finitely_generated_ideal_def
by (metis finite.emptyI finite_insert ideal_ideal_generated principal_ideal_def)
have a_in_d: "a ∈ ideal_generated {d}"
using ideal_d ideal_generated_subset_generator by blast
have b_in_d: "b ∈ ideal_generated {d}"
using ideal_d ideal_generated_subset_generator by blast
have d_in_ab: "d ∈ ideal_generated {a,b}"
using ideal_d ideal_generated_subset_generator by auto
obtain f where "(∑i∈{a,b}. f i * i) = d" using obtain_sum_ideal_generated[OF d_in_ab] by auto
from this obtain p q where d_eq: "d = p*a + q*b" using sum_two_elements' by blast
moreover have d_dvd_a: "d dvd a"
by (metis dvd_ideal_generated_singleton ideal_d ideal_generated_subset insert_commute
subset_insertI)
moreover have "d dvd b"
by (metis dvd_ideal_generated_singleton ideal_d ideal_generated_subset subset_insertI)
moreover have "d' dvd d" if d'_dvd: "d' dvd a ∧ d' dvd b" for d'
proof -
obtain s1 s2 where s1_dvd: "a = s1*d'" and s2_dvd: "b = s2*d'"
using mult.commute d'_dvd unfolding dvd_def by auto
have "d = p*a + q*b" using d_eq .
also have "...= p * s1 * d' + q * s2 *d'" unfolding s1_dvd s2_dvd by auto
also have "... = (p * s1 + q * s2) * d'" by (simp add: ring_class.ring_distribs(2))
finally show "d' dvd d" using mult.commute unfolding dvd_def by auto
qed
ultimately show "∃p q d. p * a + q * b = d ∧ d dvd a ∧ d dvd b
∧ (∀d'. d' dvd a ∧ d' dvd b ⟶ d' dvd d)" by auto
qed
end
context bezout_ring
begin
lemma exists_bezout_extended:
assumes S: "finite S" and ne: "S ≠ {}"
shows "∃f d. (∑a∈S. f a * a) = d ∧ (∀a∈S. d dvd a) ∧ (∀d'. (∀a∈S. d' dvd a) ⟶ d' dvd d)"
using S ne
proof (induct S)
case empty
then show ?case by auto
next
case (insert x S)
show ?case
proof (cases "S={}")
case True
let ?f = "λx. 1"
show ?thesis by (rule exI[of _ ?f], insert True, auto)
next
case False note ne = False
note x_notin_S = insert.hyps(2)
obtain f d where sum_eq_d: "(∑a∈S. f a * a) = d"
and d_dvd_each_a: "(∀a∈S. d dvd a)"
and d_is_gcd: "(∀d'. (∀a∈S. d' dvd a) ⟶ d' dvd d)"
using insert.hyps(3)[OF ne] by auto
have "∃p q d'. p * d + q * x = d' ∧ d' dvd d ∧ d' dvd x ∧ (∀c. c dvd d ∧ c dvd x ⟶ c dvd d')"
using exists_bezout by auto
from this obtain p q d' where pd_qx_d': "p*d + q*x = d'"
and d'_dvd_d: "d' dvd d" and d'_dvd_x: "d' dvd x"
and d'_dvd: "∀c. (c dvd d ∧ c dvd x) ⟶ c dvd d'" by blast
let ?f = "λa. if a = x then q else p * f a"
have "(∑a∈insert x S. ?f a * a) = d'"
proof -
have "(∑a∈insert x S. ?f a * a) = (∑a∈S. ?f a * a) + ?f x * x"
by (simp add: add_commute insert.hyps(1) insert.hyps(2))
also have "... = p * (∑a∈S. f a * a) + q * x"
unfolding sum_distrib_left
by (auto, rule sum.cong, insert x_notin_S,
auto simp add: mult.semigroup_axioms semigroup.assoc)
finally show ?thesis using pd_qx_d' sum_eq_d by auto
qed
moreover have "(∀a∈insert x S. d' dvd a)"
by (metis d'_dvd_d d'_dvd_x d_dvd_each_a insert_iff local.dvdE local.dvd_mult_left)
moreover have " (∀c. (∀a∈insert x S. c dvd a) ⟶ c dvd d')"
by (simp add: d'_dvd d_is_gcd)
ultimately show ?thesis by auto
qed
qed
end
lemma ideal_generated_empty: "ideal_generated {} = {0}"
unfolding ideal_generated_def using ideal_generated_0
by (metis empty_subsetI ideal_generated_def ideal_generated_subset ideal_ideal_generated
ideal_not_empty subset_singletonD)
lemma bezout_imp_all_fin_gen_ideals_are_principal:
fixes I::"'a :: bezout_ring set"
assumes fin: "finitely_generated_ideal I"
shows "principal_ideal I"
proof -
obtain S where fin_S: "finite S" and ideal_gen_S: "ideal_generated S = I"
using fin unfolding finitely_generated_ideal_def by auto
show ?thesis
proof (cases "S = {}")
case True
then show ?thesis
using ideal_gen_S unfolding True
using ideal_generated_empty ideal_generated_0 principal_ideal_def by fastforce
next
case False note ne = False
obtain d f where sum_S_d: "(∑i∈S. f i * i) = d"
and d_dvd_a: "(∀a∈S. d dvd a)" and d_is_gcd: "(∀d'. (∀a∈S. d' dvd a) ⟶ d' dvd d)"
using exists_bezout_extended[OF fin_S ne] by auto
have d_in_S: "d ∈ ideal_generated S"
by (metis fin_S ideal_def ideal_generated_subset_generator
ideal_ideal_generated sum_S_d sum_left_ideal)
have "ideal_generated {d} ⊆ ideal_generated S"
by (rule ideal_generated_singleton_subset[OF d_in_S fin_S])
moreover have "ideal_generated S ⊆ ideal_generated {d}"
proof
fix x assume x_in_S: "x ∈ ideal_generated S"
obtain f where sum_S_x: "(∑a∈S. f a * a) = x"
using fin_S obtain_sum_ideal_generated x_in_S by blast
have d_dvd_each_a: "∃k. a = k * d" if "a ∈ S" for a
by (metis d_dvd_a dvdE mult.commute that)
let ?g = "λa. SOME k. a = k*d"
have "x = (∑a∈S. f a * a)" using sum_S_x by simp
also have "... = (∑a∈S. f a * (?g a * d))"
proof (rule sum.cong)
fix a assume a_in_S: "a ∈ S"
obtain k where a_kd: "a = k * d" using d_dvd_each_a a_in_S by auto
have "a = ((SOME k. a = k * d) * d)" by (rule someI_ex, auto simp add: a_kd)
thus "f a * a = f a * ((SOME k. a = k * d) * d)" by auto
qed (simp)
also have "... = (∑a∈S. f a * ?g a * d)" by (rule sum.cong, auto)
also have "... = (∑a∈S. f a * ?g a)*d" using sum_distrib_right[of _ S d] by auto
finally show "x ∈ ideal_generated {d}"
by (meson contra_subsetD dvd_ideal_generated_singleton' dvd_triv_right
ideal_generated_in singletonI)
qed
ultimately show ?thesis unfolding principal_ideal_def using ideal_gen_S by auto
qed
qed
text ‹Now we have the required lemmas to prove the theorem that states that
a ring is B\'ezout ring if and only if every
finitely generated ideal is principal. They are the following ones.
\begin{itemize}
\item @{text "all_fin_gen_ideals_are_principal_imp_bezout"}
\item @{text "bezout_imp_all_fin_gen_ideals_are_principal"}
\end{itemize}
However, in order to prove the final lemma, we need the lemmas with no type restrictions.
For instance, we need a version of theorem @{text "bezout_imp_all_fin_gen_ideals_are_principal"}
as
@{text "OFCLASS('a,bezout_ring) ⟹"} the theorem with generic types
(i.e., @{text "'a"} with no type restrictions)
or as
@{text "class.bezout_ring _ _ _ _ ⟹"} the theorem with generic
types (i.e., @{text "'a"} with no type restrictions)
›
text ‹Thanks to local type definitions, we can obtain it automatically by means
of @{text "internalize-sort"}.›
lemma bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory:
assumes a1: "class.bezout_ring (*) (1::'b::comm_ring_1) (+) 0 (-) uminus"
shows "∀I::'b set. finitely_generated_ideal I ⟶ principal_ideal I"
using bezout_imp_all_fin_gen_ideals_are_principal[internalize_sort "'a::bezout_ring"]
using a1 by auto
text ‹The standard library does not connect @{text "OFCLASS"} and @{text "class.bezout_ring"}
in both directions. Here we show that @{text "OFCLASS ⟹ class.bezout_ring"}. ›
lemma OFCLASS_bezout_ring_imp_class_bezout_ring:
assumes "OFCLASS('a::comm_ring_1,bezout_ring_class)"
shows "class.bezout_ring ((*)::'a⇒'a⇒'a) 1 (+) 0 (-) uminus"
using assms
unfolding bezout_ring_class_def class.bezout_ring_def
using conjunctionD2[of "OFCLASS('a, comm_ring_1_class)"
"class.bezout_ring_axioms ((*)::'a⇒'a⇒'a) (+)"]
by (auto, intro_locales)
text ‹The other implication can be obtained
by thm @{text "Rings2.class.Rings2.bezout_ring.of_class.intro"} ›
thm Rings2.class.Rings2.bezout_ring.of_class.intro
text ‹Final theorem (with OFCLASS)›
lemma bezout_ring_iff_fin_gen_principal_ideal:
"(⋀I::'a::comm_ring_1 set. finitely_generated_ideal I ⟹ principal_ideal I)
≡ OFCLASS('a, bezout_ring_class)"
proof
show "(⋀I::'a::comm_ring_1 set. finitely_generated_ideal I ⟹ principal_ideal I)
⟹ OFCLASS('a, bezout_ring_class)"
using all_fin_gen_ideals_are_principal_imp_bezout [where ?'a='a] by auto
show "⋀I::'a::comm_ring_1 set. OFCLASS('a, bezout_ring_class)
⟹ finitely_generated_ideal I ⟹ principal_ideal I"
using bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory[where ?'b='a]
using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a] by auto
qed
text ‹Final theorem (with @{text "class.bezout_ring"})›
lemma bezout_ring_iff_fin_gen_principal_ideal2:
"(∀I::'a::comm_ring_1 set. finitely_generated_ideal I ⟶ principal_ideal I)
= (class.bezout_ring ((*)::'a⇒'a⇒'a) 1 (+) 0 (-) uminus)"
proof
show "∀I::'a::comm_ring_1 set. finitely_generated_ideal I ⟶ principal_ideal I
⟹ class.bezout_ring (*) 1 (+) (0::'a) (-) uminus"
using all_fin_gen_ideals_are_principal_imp_bezout[where ?'a='a]
using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a]
by auto
show "class.bezout_ring (*) 1 (+) (0::'a) (-) uminus ⟹ ∀I::'a set.
finitely_generated_ideal I ⟶ principal_ideal I"
using bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory by auto
qed
end
Theory Finite_Field_Mod_Type_Connection
section ‹Connection between @{text "mod_ring"} and @{text "mod_type"}›
text ‹This file shows that the type @{text "mod_ring"}, which is defined in the
Berlekamp--Zassenhaus development, is an instantiation of the type class @{text "mod_type"}.›
theory Finite_Field_Mod_Type_Connection
imports
Berlekamp_Zassenhaus.Finite_Field
Rank_Nullity_Theorem.Mod_Type
begin
instantiation mod_ring :: (finite) ord
begin
definition less_eq_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ bool"
where "less_eq_mod_ring x y = (to_int_mod_ring x ≤ to_int_mod_ring y)"
definition less_mod_ring :: "'a mod_ring ⇒ 'a mod_ring ⇒ bool"
where "less_mod_ring x y = (to_int_mod_ring x < to_int_mod_ring y)"
instance proof qed
end
instantiation mod_ring :: (finite) linorder
begin
instance by (intro_classes, unfold less_eq_mod_ring_def less_mod_ring_def) (transfer, auto)
end
instance mod_ring :: (finite) wellorder
proof -
have "wf {(x :: 'a mod_ring, y). x < y}"
by (auto simp add: trancl_def tranclp_less intro!: finite_acyclic_wf acyclicI)
thus "OFCLASS('a mod_ring, wellorder_class)"
by(rule wf_wellorderI) intro_classes
qed
lemma strict_mono_to_int_mod_ring: "strict_mono to_int_mod_ring"
unfolding strict_mono_def unfolding less_mod_ring_def by auto
instantiation mod_ring :: (nontriv) mod_type
begin
definition Rep_mod_ring :: "'a mod_ring ⇒ int"
where "Rep_mod_ring x = to_int_mod_ring x"
definition Abs_mod_ring :: "int ⇒ 'a mod_ring"
where "Abs_mod_ring x = of_int_mod_ring x"
instance
proof (intro_classes)
show "type_definition (Rep::'a mod_ring ⇒ int) Abs {0..<int CARD('a mod_ring)}"
unfolding Rep_mod_ring_def Abs_mod_ring_def type_definition_def by (transfer, auto)
show "1 < int CARD('a mod_ring)" using less_imp_of_nat_less nontriv by fastforce
show "0 = (Abs::int ⇒ 'a mod_ring) 0"
by (simp add: Abs_mod_ring_def)
show "1 = (Abs::int ⇒ 'a mod_ring) 1"
by (metis (mono_tags, hide_lams) Abs_mod_ring_def of_int_hom.hom_one of_int_of_int_mod_ring)
fix x y::"'a mod_ring"
show "x + y = Abs ((Rep x + Rep y) mod int CARD('a mod_ring))"
unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto)
show "- x = Abs (- Rep x mod int CARD('a mod_ring))"
unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto simp add: zmod_zminus1_eq_if)
show "x * y = Abs (Rep x * Rep y mod int CARD('a mod_ring))"
unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto)
show "x - y = Abs ((Rep x - Rep y) mod int CARD('a mod_ring))"
unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto)
show "strict_mono (Rep::'a mod_ring ⇒ int)" unfolding Rep_mod_ring_def
by (rule strict_mono_to_int_mod_ring)
qed
end
end
Theory Admits_SNF_From_Diagonal_Iff_Bezout_Ring
section ‹Generality of the Algorithm to transform from diagonal to Smith normal form›
theory Admits_SNF_From_Diagonal_Iff_Bezout_Ring
imports
Diagonal_To_Smith
Rings2_Extended
Smith_Normal_Form_JNF
Finite_Field_Mod_Type_Connection
begin
hide_const (open) mat
text ‹This section provides a formal proof on the generality of the algorithm that transforms
a diagonal matrix into its Smith normal form. More concretely, we prove that
all diagonal matrices with coefficients in a ring R admit Smith normal form if and only if
R is a B\'ezout ring.
Since our algorithm is defined for B\'ezout rings and for any matrices (including non-square and
singular ones), this means that it does not exist another algorithm that performs the transformation
in a more abstract structure.›
text ‹Firstly, we hide some definitions and facts, since we are interested in the ones
developed for the @{text "mod_type"} class.›
hide_const (open) Bij_Nat.to_nat Bij_Nat.from_nat Countable.to_nat Countable.from_nat
hide_fact (open) Bij_Nat.to_nat_from_nat_id Bij_Nat.to_nat_less_card
definition "admits_SNF_HA (A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) = (isDiagonal A
⟶ (∃P Q. invertible ((P::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}))
∧ invertible (Q::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) ∧ Smith_normal_form (P**A**Q)))"
definition "admits_SNF_JNF A = (square_mat (A::'a::comm_ring_1 mat) ∧ isDiagonal_mat A
⟶ (∃P Q. P ∈ carrier_mat (dim_row A) (dim_row A) ∧ Q ∈ carrier_mat (dim_row A) (dim_row A)
∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat (P*A*Q)))"
subsection ‹Proof of the @{text "⟸"} implication in HA.›
lemma exists_f_PAQ_Aii':
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
assumes diag_A: "isDiagonal A"
shows "∃f. (P**A**Q) $h i $h i = (∑i∈(UNIV::'n set). f i * A $h i $h i)"
proof -
have rw: "(∑ka∈UNIV. P $h i $h ka * A $h ka $h k) = P $h i $h k * A $h k $h k" for k
proof -
have "(∑ka∈UNIV. P $h i $h ka * A $h ka $h k) = (∑ka∈{k}. P $h i $h ka * A $h ka $h k)"
proof (rule sum.mono_neutral_right, auto)
fix ia assume "P $h i $h ia * A $h ia $h k ≠ 0"
hence "A $h ia $h k ≠ 0" by auto
thus" ia = k" using diag_A unfolding isDiagonal_def by auto
qed
also have "... = P $h i $h k * A $h k $h k" by auto
finally show ?thesis .
qed
let ?f = "λk. (∑ka∈UNIV. P $h i $h ka) * Q $h k $h i"
have "(P**A**Q) $h i $h i = (∑k∈UNIV. (∑ka∈UNIV. P $h i $h ka * A $h ka $h k) * Q $h k $h i)"
unfolding matrix_matrix_mult_def by auto
also have "... = (∑k∈UNIV. P $h i $h k * Q $h k $h i * A $h k $h k)"
unfolding rw
by (meson semiring_normalization_rules(16))
finally show ?thesis by auto
qed
text ‹We apply @{text "internalize_sort"} to the lemma that we need›
lemmas diagonal_to_Smith_PQ_exists_internalize_sort
= diagonal_to_Smith_PQ_exists[internalize_sort "'a :: bezout_ring"]
text ‹We get the @{text "⟸"} implication in HA.›
lemma bezout_ring_imp_diagonal_admits_SNF:
assumes of: "OFCLASS('a::comm_ring_1, bezout_ring_class)"
shows "∀A::'a^'n::{mod_type}^'n::{mod_type}. isDiagonal A
⟶ (∃P Q.
invertible (P::'a^'n::mod_type^'n::mod_type) ∧
invertible (Q::'a^'n::mod_type^'n::mod_type) ∧
Smith_normal_form (P**A**Q))"
proof (rule allI, rule impI)
fix A::"'a^'n::{mod_type}^'n::{mod_type}"
assume A: "isDiagonal A"
have br: "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus"
by (rule OFCLASS_bezout_ring_imp_class_bezout_ring[OF of])
show "∃P Q.
invertible (P::'a^'n::mod_type^'n::mod_type) ∧
invertible (Q::'a^'n::mod_type^'n::mod_type) ∧
Smith_normal_form (P**A**Q)" by (rule diagonal_to_Smith_PQ_exists_internalize_sort[OF br A])
qed
subsection ‹Trying to prove the @{text "⟹"} implication in HA.›
text‹There is a problem: we need to define a matrix with a concrete dimension, which is not
possible in HA (the dimension depends on the number of elements on a set, and Isabelle/HOL does
not feature dependent types)›
lemma
assumes "∀A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A"
shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" oops
subsection ‹Proof of the @{text "⟹"} implication in JNF.›
lemma exists_f_PAQ_Aii:
assumes diag_A: "isDiagonal_mat (A::'a:: comm_ring_1 mat)"
and P: "P ∈ carrier_mat n n"
and A: "A ∈ carrier_mat n n"
and Q: "Q ∈ carrier_mat n n"
and i: "i < n"
shows "∃f. (P*A*Q) $$ (i, i) = (∑i∈set (diag_mat A). f i * i)"
proof -
let ?xs = "diag_mat A"
let ?n = "length ?xs"
have length_n: "length (diag_mat A) = n"
by (metis A carrier_matD(1) diag_mat_def diff_zero length_map length_upt)
have xs_index: "?xs ! i = A $$ (i, i)" if "i<n" for i
by (metis (no_types, lifting) add.left_neutral diag_mat_def length_map
length_n length_upt nth_map_upt that)
have i_length: "i<length ?xs" using i length_n by auto
have rw: "(∑ka = 0..<?n. P $$ (i, ka) * A $$ (ka, k)) = P $$(i, k) * A $$ (k, k)"
if k: "k<length ?xs" for k
proof -
have "(∑ka= 0..<?n. P $$ (i, ka) * A $$ (ka, k)) = (∑ka∈{k}. P $$ (i, ka) * A $$ (ka, k))"
by (rule sum.mono_neutral_right, auto simp add: k,
insert diag_A A length_n that, unfold isDiagonal_mat_def, fastforce)
also have "... = P $$(i, k) * A $$ (k, k)" by auto
finally show ?thesis .
qed
let ?positions_of ="λx. {i. A$$(i,i) = x ∧ i<length ?xs}"
let ?T="set ?xs"
let ?S ="{0..<?n}"
let ?f = "λx.(∑k∈{i. A $$ (i, i) = x ∧ i < length (diag_mat A)}. P $$ (i, k) * Q $$ (k, i))"
let ?g = "(λk. P $$ (i,k) * Q $$ (k, i) * A $$ (k, k))"
have UNION_positions_of: "⋃(?positions_of ` ?T) = ?S" unfolding diag_mat_def by auto
have "(P*A*Q) $$ (i,i) = (∑ia = 0..<?n.
Matrix.row (Matrix.mat ?n ?n (λ(i, j). ∑ia = 0..<?n.
Matrix.row P i $v ia * col A j $v ia)) i $v ia * col Q i $v ia)"
unfolding times_mat_def scalar_prod_def
using P Q i_length length_n A by auto
also have "... = (∑k = 0..<?n. (∑ka = 0..<?n. P$$(i,ka) * A$$(ka,k)) * Q $$ (k,i))"
proof (rule sum.cong, auto)
fix x assume x: "x < length ?xs"
have rw_colQ: "col Q i $v x = Q $$ (x, i)"
using Q i_length x length_n A by auto
have rw2: " Matrix.row (Matrix.mat ?n ?n
(λ(i, j). ∑ia = 0..<length ?xs. Matrix.row P i $v ia * col A j $v ia)) i $v x
=(∑ia = 0..<length ?xs. Matrix.row P i $v ia * col A x $v ia)"
unfolding row_mat[OF i_length] unfolding index_vec[OF x] by auto
also have "... = (∑ia = 0..<length ?xs. P $$ (i,ia) * A $$ (ia,x))"
by (rule sum.cong, insert P i_length x length_n A, auto)
finally show "Matrix.row (Matrix.mat ?n ?n (λ(i, j). ∑ia = 0..<?n. Matrix.row P i $v ia
* col A j $v ia)) i $v x * col Q i $v x
= (∑ka = 0..<?n. P $$ (i, ka) * A $$ (ka, x)) * Q $$ (x, i)" unfolding rw_colQ by auto
qed
also have "... = (∑k = 0..<?n. P $$ (i,k) * Q $$ (k, i) * A $$ (k, k))"
by (smt rw semiring_normalization_rules(16) sum.ivl_cong)
also have "... = sum ?g (⋃(?positions_of ` ?T))"
using UNION_positions_of by auto
also have "... = (∑x∈?T. sum ?g (?positions_of x))"
by (rule sum.UNION_disjoint, auto)
also have "... = (∑x∈set (diag_mat A). (∑k∈{i. A $$ (i, i) = x ∧ i < length (diag_mat A)}.
P $$ (i, k) * Q $$ (k, i)) * x)"
by (rule sum.cong, auto simp add: Groups_Big.sum_distrib_right)
finally show ?thesis by auto
qed
text ‹Proof of the @{text "⟹"} implication in JNF.›
lemma diagonal_admits_SNF_imp_bezout_ring_JNF:
assumes admits_SNF: "∀A n. (A::'a mat) ∈ carrier_mat n n ∧ isDiagonal_mat A
⟶ (∃P Q. P ∈ carrier_mat n n ∧ Q ∈ carrier_mat n n ∧ invertible_mat P ∧ invertible_mat Q
∧ Smith_normal_form_mat (P*A*Q))"
shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule allI, rule impI)
fix I::"'a set"
assume fin: "finitely_generated_ideal I"
obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S"
using fin unfolding finitely_generated_ideal_def by auto
show "principal_ideal I"
proof (cases "S = {}")
case True
then show ?thesis
by (metis ideal_generated_0 ideal_generated_empty ig_S principal_ideal_def)
next
case False
obtain xs where set_xs: "set xs = S" and d: "distinct xs"
using finite_distinct_list[OF fin_S] by blast
hence length_eq_card: "length xs = card S" using distinct_card by force
let ?n = "length xs"
let ?A = "Matrix.mat ?n ?n (λ(a,b). if a = b then xs!a else 0)"
have A_carrier: "?A ∈ carrier_mat ?n ?n" by auto
have diag_A: "isDiagonal_mat ?A" unfolding isDiagonal_mat_def by auto
have set_xs_eq: "set xs = {?A$$(i,i)| i. i<dim_row ?A}"
by (auto, smt case_prod_conv d distinct_Ex1 index_mat(1))
have set_xs_diag_mat: "set xs = set (diag_mat ?A)"
using set_xs_eq unfolding diag_mat_def by auto
obtain P Q where P: "P ∈ carrier_mat ?n ?n"
and Q: "Q ∈ carrier_mat ?n ?n" and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
and SNF_PAQ: "Smith_normal_form_mat (P*?A*Q)"
using admits_SNF A_carrier diag_A by blast
define ys where ys_def: "ys = diag_mat (P*?A*Q)"
have ys: "∀i<?n. ys ! i = (P*?A*Q) $$ (i,i)" using P by (auto simp add: ys_def diag_mat_def)
have length_ys: "length ys = ?n" unfolding ys_def
by (metis (no_types, lifting) P carrier_matD(1) diag_mat_def
index_mult_mat(2) length_map map_nth)
have n0: "?n > 0" using False set_xs by blast
have set_ys_diag_mat: "set ys = set (diag_mat (P*?A*Q))" using ys_def by auto
let ?i = "ys ! 0"
have dvd_all: "∀a ∈ set ys. ?i dvd a"
proof
fix a assume a: "a ∈ set ys"
obtain j where ys_j_a: "ys ! j = a" and jn: "j<?n" by (metis a in_set_conv_nth length_ys)
have jP: "j < dim_row P" using jn P by auto
have jQ: "j < dim_col Q" using jn Q by auto
have "(P*?A*Q)$$(0,0) dvd (P*?A*Q)$$(j,j)"
by (rule SNF_first_divides[OF SNF_PAQ], auto simp add: jP jQ)
thus "ys ! 0 dvd a" using ys length_ys ys_j_a jn n0 by auto
qed
have "ideal_generated S = ideal_generated (set xs)" using set_xs by simp
also have "... = ideal_generated (set ys)"
proof
show "ideal_generated (set xs) ⊆ ideal_generated (set ys)"
proof (rule ideal_generated_subset2, rule ballI)
fix b assume b: "b ∈ set xs"
obtain i where b_A_ii: "b = ?A $$ (i,i)" and i_length: "i<length xs"
using b set_xs_eq by auto
obtain P' where inverts_mat_P': "inverts_mat P P' ∧ inverts_mat P' P"
using inv_P unfolding invertible_mat_def by auto
have P': "P' ∈ carrier_mat ?n ?n"
using inverts_mat_P'
unfolding carrier_mat_def inverts_mat_def
by (auto,metis P carrier_matD index_mult_mat(3) one_carrier_mat)+
obtain Q' where inverts_mat_Q': "inverts_mat Q Q' ∧ inverts_mat Q' Q"
using inv_Q unfolding invertible_mat_def by auto
have Q': "Q' ∈ carrier_mat ?n ?n"
using inverts_mat_Q'
unfolding carrier_mat_def inverts_mat_def
by (auto,metis Q carrier_matD index_mult_mat(3) one_carrier_mat)+
have rw_PAQ: "(P'*(P*?A*Q)*Q') $$ (i, i) = ?A $$ (i,i)"
using inv_P'PAQQ'[OF A_carrier P _ _ Q P' Q'] inverts_mat_P' inverts_mat_Q' by auto
have diag_PAQ: "isDiagonal_mat (P*?A*Q)"
using SNF_PAQ unfolding Smith_normal_form_mat_def by auto
have PAQ_carrier: "(P*?A*Q) ∈ carrier_mat ?n ?n" using P Q by auto
obtain f where f: "(P'*(P*?A*Q)*Q') $$ (i, i) = (∑i∈set (diag_mat (P*?A*Q)). f i * i)"
using exists_f_PAQ_Aii[OF diag_PAQ P' PAQ_carrier Q' i_length] by auto
hence "?A $$ (i,i) = (∑i∈set (diag_mat (P*?A*Q)). f i * i)" unfolding rw_PAQ .
thus "b∈ ideal_generated (set ys)"
unfolding ideal_explicit using set_ys_diag_mat b_A_ii by auto
qed
show "ideal_generated (set ys) ⊆ ideal_generated (set xs)"
proof (rule ideal_generated_subset2, rule ballI)
fix b assume b: "b ∈ set ys"
have d: "distinct (diag_mat ?A)"
by (metis (no_types, lifting) A_carrier card_distinct carrier_matD(1) diag_mat_def
length_eq_card length_map map_nth set_xs set_xs_diag_mat)
obtain i where b_PAQ_ii: "(P*?A*Q) $$ (i,i) = b" and i_length: "i<length xs" using b ys
by (metis (no_types, lifting) in_set_conv_nth length_ys)
obtain f where "(P * ?A * Q) $$ (i, i) = (∑i∈set (diag_mat ?A). f i * i)"
using exists_f_PAQ_Aii[OF diag_A P _ Q i_length] by auto
thus "b ∈ ideal_generated (set xs)"
using b_PAQ_ii unfolding set_xs_diag_mat ideal_explicit by auto
qed
qed
also have "... = ideal_generated (set ys - (set ys - {ys!0}))"
proof (rule ideal_generated_dvd_eq_diff_set)
show "?i ∈ set ys" using n0
by (simp add: length_ys)
show "?i ∉ set ys - {?i}" by auto
show "∀j∈set ys - {?i}. ?i dvd j" using dvd_all by auto
show "finite (set ys - {?i})" by auto
qed
also have "... = ideal_generated {?i}"
by (metis Diff_cancel Diff_not_in insert_Diff insert_Diff_if length_ys n0 nth_mem)
finally show "principal_ideal I" unfolding principal_ideal_def using ig_S by auto
qed
qed
corollary diagonal_admits_SNF_imp_bezout_ring_JNF_alt:
assumes admits_SNF: "∀A. square_mat (A::'a mat) ∧ isDiagonal_mat A
⟶ (∃P Q. P ∈ carrier_mat (dim_row A) (dim_row A)
∧ Q ∈ carrier_mat (dim_row A) (dim_row A) ∧ invertible_mat P ∧ invertible_mat Q
∧ Smith_normal_form_mat (P*A*Q))"
shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule diagonal_admits_SNF_imp_bezout_ring_JNF, rule allI, rule allI, rule impI)
fix A::"'a mat" and n assume A: "A ∈ carrier_mat n n ∧ isDiagonal_mat A"
have "square_mat A" using A by auto
thus "∃P Q. P ∈ carrier_mat n n ∧ Q ∈ carrier_mat n n
∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat (P * A * Q)"
using A admits_SNF by blast
qed
subsection ‹Trying to transfer the @{text "⟹"} implication to HA.›
text ‹We first hide some constants defined in @{text "Mod_Type_Connect"} in order to use the ones
presented in @{text "Perron_Frobenius.HMA_Connect"} by default.›
context
includes lifting_syntax
begin
lemma to_nat_mod_type_Bij_Nat:
fixes a::"'n::mod_type"
obtains b::'n where "mod_type_class.to_nat a = Bij_Nat.to_nat b"
using Bij_Nat.to_nat_from_nat_id mod_type_class.to_nat_less_card by metis
lemma inj_on_Bij_nat_from_nat: "inj_on (Bij_Nat.from_nat::nat ⇒ 'a) {0..<CARD('a::finite)}"
by (auto simp add: inj_on_def Bij_Nat.from_nat_def length_univ_list_card
nth_eq_iff_index_eq univ_list(1))
text ‹This lemma only holds if $a$ and $b$ have the same type. Otherwise,
it is possible that @{text "Bij_Nat.to_nat a = Bij_Nat.to_nat b"}›
lemma Bij_Nat_to_nat_neq:
fixes a b ::"'n::mod_type"
assumes "to_nat a ≠ to_nat b"
shows "Bij_Nat.to_nat a ≠ Bij_Nat.to_nat b"
using assms to_nat_inj by blast
text ‹The following proof (a transfer rule for diagonal matrices)
is weird, since it does not hold
@{text "Bij_Nat.to_nat a = mod_type_class.to_nat a"}.
At first, it seems possible to obtain the element $a'$ that satisfies
@{text "Bij_Nat.to_nat a' = mod_type_class.to_nat a"} and then continue with the proof, but then
we cannot prove @{text "HMA_I (Bij_Nat.to_nat a') a"}.
This means that we must use the previous lemma @{text "Bij_Nat_to_nat_neq"}, but this imposes the
matrix to be square.
›
lemma HMA_isDiagonal[transfer_rule]: "(HMA_M ===> (=))
isDiagonal_mat (isDiagonal::('a::{zero}^'n::{mod_type}^'n::{mod_type} => bool))"
proof (intro rel_funI, goal_cases)
case (1 x y)
note rel_xy [transfer_rule] = "1"
have "y $h a $h b = 0"
if all0: "∀i j. i ≠ j ∧ i < dim_row x ∧ j < dim_col x ⟶ x $$ (i, j) = 0"
and a_noteq_b: "a ≠ b" for a::'n and b::'n
proof -
have "to_nat a ≠ to_nat b" using a_noteq_b by auto
hence distinct: "Bij_Nat.to_nat a ≠ Bij_Nat.to_nat b" by (rule Bij_Nat_to_nat_neq)
moreover have "Bij_Nat.to_nat a < dim_row x" and "Bij_Nat.to_nat b < dim_col x"
using Bij_Nat.to_nat_less_card dim_row_transfer_rule rel_xy dim_col_transfer_rule
by fastforce+
ultimately have b: "x $$ (Bij_Nat.to_nat a, Bij_Nat.to_nat b) = 0" using all0 by auto
have [transfer_rule]: "HMA_I (Bij_Nat.to_nat a) a" by (simp add: HMA_I_def)
have [transfer_rule]: "HMA_I (Bij_Nat.to_nat b) b" by (simp add: HMA_I_def)
have "index_hma y a b = 0" using b by (transfer', auto)
thus ?thesis unfolding index_hma_def .
qed
moreover have "x $$ (i, j) = 0"
if all0: "∀a b. a ≠ b ⟶ y $h a $h b = 0"
and ij: "i ≠ j" and i: "i < dim_row x" and j: "j < dim_col x" for i j
proof -
have i_n: "i < CARD('n)" and j_n: "j < CARD('n)"
using i j rel_xy dim_row_transfer_rule dim_col_transfer_rule
by fastforce+
let ?i' = "Bij_Nat.from_nat i::'n"
let ?j' = "Bij_Nat.from_nat j::'n"
have i'_neq_j': "?i' ≠ ?j'" using ij i_n j_n Bij_Nat.from_nat_inj by blast
hence y0: "index_hma y ?i' ?j' = 0" using all0 unfolding index_hma_def by auto
have [transfer_rule]: "HMA_I i ?i'" unfolding HMA_I_def
by (simp add: Bij_Nat.to_nat_from_nat_id i_n)
have [transfer_rule]: "HMA_I j ?j'" unfolding HMA_I_def
by (simp add: Bij_Nat.to_nat_from_nat_id j_n)
show ?thesis using y0 by (transfer, auto)
qed
ultimately show ?case unfolding isDiagonal_mat_def isDiagonal_def
by auto
qed
text ‹Indeed, we can prove the transfer rules with the new connection based on the
@{text "mod_type"} class, which was developed in the @{text "Mod_Type_Connect"} file›
text ‹This is the same lemma as the one presented above, but now using the @{text "to_nat"} function
defined in the @{text "mod_type"} class and then we can prove it for non-square matrices,
which is very useful since our algorithms are not restricted to square matrices.›
lemma HMA_isDiagonal_Mod_Type[transfer_rule]: "(Mod_Type_Connect.HMA_M ===> (=))
isDiagonal_mat (isDiagonal::('a::{zero}^'n::{mod_type}^'m::{mod_type} => bool))"
proof (intro rel_funI, goal_cases)
case (1 x y)
note rel_xy [transfer_rule] = "1"
have "y $h a $h b = 0"
if all0: "∀i j. i ≠ j ∧ i < dim_row x ∧ j < dim_col x ⟶ x $$ (i, j) = 0"
and a_noteq_b: "to_nat a ≠ to_nat b" for a::'m and b::'n
proof -
have distinct: "to_nat a ≠ to_nat b" using a_noteq_b by auto
moreover have "to_nat a < dim_row x" and "to_nat b < dim_col x"
using to_nat_less_card rel_xy
using Mod_Type_Connect.dim_row_transfer_rule Mod_Type_Connect.dim_col_transfer_rule
by fastforce+
ultimately have b: "x $$ (to_nat a, to_nat b) = 0" using all0 by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat a) a"
by (simp add: Mod_Type_Connect.HMA_I_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat b) b"
by (simp add: Mod_Type_Connect.HMA_I_def)
have "index_hma y a b = 0" using b by (transfer', auto)
thus ?thesis unfolding index_hma_def .
qed
moreover have "x $$ (i, j) = 0"
if all0: "∀a b. to_nat a ≠ to_nat b ⟶ y $h a $h b = 0"
and ij: "i ≠ j" and i: "i < dim_row x" and j: "j < dim_col x" for i j
proof -
have i_n: "i < CARD('m)"
using i rel_xy by (simp add: Mod_Type_Connect.dim_row_transfer_rule)
have j_n: "j < CARD('n)"
using j rel_xy by (simp add: Mod_Type_Connect.dim_col_transfer_rule)
let ?i' = "from_nat i::'m"
let ?j' = "from_nat j::'n"
have "to_nat ?i' ≠ to_nat ?j'"
by (simp add: i_n ij j_n mod_type_class.to_nat_from_nat_id)
hence y0: "index_hma y ?i' ?j' = 0" using all0 unfolding index_hma_def by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'"
unfolding Mod_Type_Connect.HMA_I_def
by (simp add: to_nat_from_nat_id i_n)
have [transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'"
unfolding Mod_Type_Connect.HMA_I_def
by (simp add: to_nat_from_nat_id j_n)
show ?thesis using y0 by (transfer, auto)
qed
ultimately show ?case unfolding isDiagonal_mat_def isDiagonal_def
by auto
qed
text‹We state the transfer rule using the relations developed in the new bride of the file
@{text "Mod_Type_Connect"}.›
lemma HMA_SNF[transfer_rule]: "(Mod_Type_Connect.HMA_M ===> (=)) Smith_normal_form_mat
(Smith_normal_form::'a::{comm_ring_1}^'n::{mod_type}^'m::{mod_type}⇒bool)"
proof (intro rel_funI, goal_cases)
case (1 x y)
note rel_xy[transfer_rule] = "1"
have "y $h a $h b dvd y $h (a + 1) $h (b + 1)"
if SNF_condition: "∀a. Suc a < dim_row x ∧ Suc a < dim_col x
⟶ x $$ (a, a) dvd x $$ (Suc a, Suc a)"
and a1: "Suc (to_nat a) < nrows y" and a2: "Suc (to_nat b) < ncols y"
and ab: "to_nat a = to_nat b" for a::'m and b::'n
proof -
have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat a) a"
by (simp add: Mod_Type_Connect.HMA_I_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat (a+1)) (a+1)"
by (simp add: Mod_Type_Connect.HMA_I_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat b) b"
by (simp add: Mod_Type_Connect.HMA_I_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat (b+1)) (b+1)"
by (simp add: Mod_Type_Connect.HMA_I_def)
have "Suc (to_nat a) < dim_row x" using a1
by (metis Mod_Type_Connect.dim_row_transfer_rule nrows_def rel_xy)
moreover have "Suc (to_nat b) < dim_col x"
by (metis Mod_Type_Connect.dim_col_transfer_rule a2 ncols_def rel_xy)
ultimately have "x $$ (to_nat a, to_nat b) dvd x $$ (Suc (to_nat a), Suc (to_nat b))"
using SNF_condition by (simp add: ab)
also have "... = x $$ (to_nat (a+1), to_nat (b+1))"
by (metis Suc_eq_plus1 a1 a2 nrows_def ncols_def to_nat_suc)
finally have SNF_cond: "x $$ (to_nat a, to_nat b) dvd x $$ (to_nat (a + 1), to_nat (b + 1))" .
have "x $$ (to_nat a, to_nat b) = index_hma y a b" by (transfer, simp)
moreover have "x $$ (to_nat (a + 1), to_nat (b + 1)) = index_hma y (a+1) (b+1)"
by (transfer, simp)
ultimately show ?thesis using SNF_cond unfolding index_hma_def by auto
qed
moreover have "x $$ (a, a) dvd x $$ (Suc a, Suc a)"
if SNF: "∀a b. to_nat a = to_nat b ∧ Suc (to_nat a) < nrows y ∧ Suc (to_nat b) < ncols y
⟶ y $h a $h b dvd y $h (a + 1) $h (b + 1)"
and a1: "Suc a < dim_row x" and a2: "Suc a < dim_col x" for a
proof -
have dim_row_CARD: "dim_row x = CARD('m)"
using Mod_Type_Connect.dim_row_transfer_rule rel_xy by blast
have dim_col_CARD: "dim_col x = CARD('n)"
using Mod_Type_Connect.dim_col_transfer_rule rel_xy by blast
let ?a' = "from_nat a::'m"
let ?b' = "from_nat a::'n"
have Suc_a_less_CARD: "a + 1 < CARD('m)" using a1 dim_row_CARD by auto
have Suc_b_less_CARD: "a + 1 < CARD('n)" using a2
by (metis Mod_Type_Connect.dim_col_transfer_rule Suc_eq_plus1 rel_xy)
have aa'[transfer_rule]: "Mod_Type_Connect.HMA_I a ?a'"
unfolding Mod_Type_Connect.HMA_I_def
by (metis Suc_a_less_CARD add_lessD1 mod_type_class.to_nat_from_nat_id)
have [transfer_rule]: "Mod_Type_Connect.HMA_I (a+1) (?a' + 1)"
unfolding Mod_Type_Connect.HMA_I_def
unfolding from_nat_suc[symmetric] using to_nat_from_nat_id[OF Suc_a_less_CARD] by auto
have ab'[transfer_rule]: "Mod_Type_Connect.HMA_I a ?b'"
unfolding Mod_Type_Connect.HMA_I_def
by (metis Suc_b_less_CARD add_lessD1 mod_type_class.to_nat_from_nat_id)
have [transfer_rule]: "Mod_Type_Connect.HMA_I (a+1) (?b' + 1)"
unfolding Mod_Type_Connect.HMA_I_def
unfolding from_nat_suc[symmetric] using to_nat_from_nat_id[OF Suc_b_less_CARD] by auto
have aa'1: "a = to_nat ?a'" using aa' by (simp add: Mod_Type_Connect.HMA_I_def)
have ab'1: "a = to_nat ?b'" using ab' by (simp add: Mod_Type_Connect.HMA_I_def)
have "Suc (to_nat ?a') < nrows y" using a1 dim_row_CARD
by (simp add: mod_type_class.to_nat_from_nat_id nrows_def)
moreover have "Suc (to_nat ?b') < ncols y" using a2 dim_col_CARD
by (simp add: mod_type_class.to_nat_from_nat_id ncols_def)
ultimately have SNF': "y $h ?a' $h ?b' dvd y $h (?a' + 1) $h (?b' + 1)"
using SNF ab'1 aa'1 by auto
have "index_hma y ?a' ?b' = x $$ (a, a)" by (transfer, simp)
moreover have "index_hma y (?a'+1) (?b'+1) = x $$ (a+1, a+1)" by (transfer, simp)
ultimately show ?thesis using SNF' unfolding index_hma_def by auto
qed
ultimately show ?case unfolding Smith_normal_form_mat_def Smith_normal_form_def
using rel_xy by (auto) (transfer', auto)+
qed
lemma HMA_admits_SNF [transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'n::{mod_type} ^ 'n::{mod_type} ⇒ _) ===> (=))
admits_SNF_JNF admits_SNF_HA"
proof (intro rel_funI, goal_cases)
case (1 x y)
note [transfer_rule] = this
hence id: "dim_row x = CARD('n)" by (auto simp: Mod_Type_Connect.HMA_M_def)
then show ?case unfolding admits_SNF_JNF_def admits_SNF_HA_def
by (transfer, auto, metis "1" Mod_Type_Connect.dim_col_transfer_rule)
qed
end
text‹Here we have a problem when trying to apply local type definitions›
lemma diagonal_admits_SNF_imp_bezout_ring:
assumes admits_SNF: "∀A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. isDiagonal A
⟶ (∃P Q. invertible (P::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})
∧ invertible (Q::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})
∧ Smith_normal_form (P**A**Q))"
shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule diagonal_admits_SNF_imp_bezout_ring_JNF, auto)
fix A::"'a mat" and n
assume A: "A ∈ carrier_mat n n" and diag_A: "isDiagonal_mat A"
have a: "∀A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A"
using admits_SNF unfolding admits_SNF_HA_def .
have JNF: "∀(A::'a mat)∈ carrier_mat CARD('n) CARD('n). admits_SNF_JNF A"
proof
fix A::"'a mat"
assume A: "A ∈ carrier_mat CARD('n) CARD('n)"
let ?B = "(Mod_Type_Connect.to_hma⇩m A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})"
have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?B"
using A unfolding Mod_Type_Connect.HMA_M_def by auto
have b: "admits_SNF_HA ?B" using a by auto
show "admits_SNF_JNF A" using b by transfer
qed
thus "∃P. P ∈ carrier_mat n n ∧
(∃Q. Q ∈ carrier_mat n n ∧ invertible_mat P
∧ invertible_mat Q ∧ Smith_normal_form_mat (P * A * Q))"
using JNF A diag_A unfolding admits_SNF_JNF_def unfolding square_mat.simps oops
text‹This means that the @{text "⟹"} implication cannot be proven in HA, since we cannot quantify
over type variables in Isabelle/HOL. We then prove both implications in JNF.›
subsection ‹Transfering the @{text "⟸"} implication from HA to JNF using transfer rules
and local type definitions›
lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring:
assumes of: "OFCLASS('a::comm_ring_1, bezout_ring_class)"
shows "∀A::'a^'n::nontriv mod_ring^'n::nontriv mod_ring. isDiagonal A
⟶ (∃P Q.
invertible (P::'a^'n::nontriv mod_ring^'n::nontriv mod_ring) ∧
invertible (Q::'a^'n::nontriv mod_ring^'n::nontriv mod_ring) ∧
Smith_normal_form (P**A**Q))"
using bezout_ring_imp_diagonal_admits_SNF[OF assms] by auto
lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits:
assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
shows "∀A::'a^'n::nontriv mod_ring^'n::nontriv mod_ring. admits_SNF_HA A"
using bezout_ring_imp_diagonal_admits_SNF
[OF Rings2.class.Rings2.bezout_ring.of_class.intro[OF of]]
unfolding admits_SNF_HA_def by auto
text‹I start here to apply local type definitions›
context
fixes p::nat
assumes local_typedef: "∃(Rep :: ('b ⇒ int)) Abs. type_definition Rep Abs {0..<p :: int}"
and p: "p>1"
begin
lemma type_to_set:
shows "class.nontriv TYPE('b)" (is ?a) and "p=CARD('b)" (is ?b)
proof -
from local_typedef obtain Rep::"('b ⇒ int)" and Abs
where t: "type_definition Rep Abs {0..<p :: int}" by auto
have "card (UNIV :: 'b set) = card {0..<p}" using t type_definition.card by fastforce
also have "... = p" by auto
finally show ?b ..
then show ?a unfolding class.nontriv_def using p by auto
qed
text‹I transfer the lemma from HA to JNF, substituting @{text "CARD('n)"} by $p$.
I apply @{text "internalize-sort"} to @{text "'n"} and get rid of
the @{text "nontriv"} restriction.›
lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux:
assumes "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
shows "Ball {A::'a::comm_ring_1 mat. A ∈ carrier_mat p p} admits_SNF_JNF"
using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits[untransferred, unfolded CARD_mod_ring,
internalize_sort "'n::nontriv", where ?'a='b]
unfolding type_to_set(2)[symmetric] using type_to_set(1) assms by auto
end
text‹The @{text "⟸"} implication in JNF›
text‹Since @{text "nontriv"} imposes the type to have more than one element,
the cases $n=0$ (@{text "A ∈ carrier_mat 0 0"}) and $n = 1$ (@{text "A ∈ carrier_mat 1 1"})
must be treated separately.›
lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux2:
assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
shows "∀(A::'a mat)∈carrier_mat n n. admits_SNF_JNF A"
proof (cases "n = 0")
case True
show ?thesis
by (rule, unfold True admits_SNF_JNF_def isDiagonal_mat_def invertible_mat_def
Smith_normal_form_mat_def carrier_mat_def inverts_mat_def, fastforce)
next
case False note not0 = False
show ?thesis
proof (cases "n=1")
case True
show ?thesis
by (rule, unfold True admits_SNF_JNF_def isDiagonal_mat_def invertible_mat_def
Smith_normal_form_mat_def carrier_mat_def inverts_mat_def, auto)
(metis dvd_1_left index_one_mat(2) index_one_mat(3) less_Suc0 nat_dvd_not_less
right_mult_one_mat' zero_less_Suc)
next
case False
then have "n>1" using not0 by auto
then show ?thesis
using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux[cancel_type_definition, of n] of
by auto
qed
qed
text ‹Alternative statements›
lemma bezout_ring_imp_diagonal_admits_SNF_JNF:
assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
shows "∀A::'a mat. admits_SNF_JNF A"
proof
fix A::"'a mat"
have "A∈ carrier_mat (dim_row A) (dim_col A)" unfolding carrier_mat_def by auto
thus "admits_SNF_JNF A"
using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux2[OF of]
by (metis admits_SNF_JNF_def square_mat.elims(2))
qed
lemma admits_SNF_JNF_alt_def:
"(∀A::'a::comm_ring_1 mat. admits_SNF_JNF A)
= (∀A n. (A::'a mat) ∈ carrier_mat n n ∧ isDiagonal_mat A
⟶ (∃P Q. P ∈ carrier_mat n n ∧ Q ∈ carrier_mat n n ∧ invertible_mat P ∧ invertible_mat Q
∧ Smith_normal_form_mat (P*A*Q)))" (is "?a = ?b")
by (auto simp add: admits_SNF_JNF_def, metis carrier_matD(1) carrier_matD(2), blast)
subsection ‹Final theorem in JNF›
text ‹Final theorem using @{text "class.bezout_ring"}›
theorem diagonal_admits_SNF_iff_bezout_ring:
shows "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus
⟷ (∀A::'a mat. admits_SNF_JNF A)" (is "?a ⟷ ?b")
proof
assume ?a
thus ?b using bezout_ring_imp_diagonal_admits_SNF_JNF by auto
next
assume b: ?b
have rw: "∀A n. (A::'a mat) ∈ carrier_mat n n ∧ isDiagonal_mat A ⟶
(∃P Q. P ∈ carrier_mat n n ∧ Q ∈ carrier_mat n n ∧ invertible_mat P
∧ invertible_mat Q ∧ Smith_normal_form_mat (P * A * Q))"
using admits_SNF_JNF_alt_def b by auto
show ?a
using diagonal_admits_SNF_imp_bezout_ring_JNF[OF rw]
using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a]
by auto
qed
text ‹Final theorem using @{text "OFCLASS"}›
theorem diagonal_admits_SNF_iff_bezout_ring':
shows "OFCLASS('a::comm_ring_1, bezout_ring_class) ≡ (⋀A::'a mat. admits_SNF_JNF A)"
proof
fix A::"'a mat"
assume a: "OFCLASS('a, bezout_ring_class)"
show "admits_SNF_JNF A"
using OFCLASS_bezout_ring_imp_class_bezout_ring[OF a] diagonal_admits_SNF_iff_bezout_ring
by auto
next
assume "(⋀A::'a mat. admits_SNF_JNF A)"
hence *: "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus"
using diagonal_admits_SNF_iff_bezout_ring by auto
show "OFCLASS('a, bezout_ring_class)"
by (rule Rings2.class.Rings2.bezout_ring.of_class.intro, rule *)
qed
end
Theory SNF_Uniqueness
section ‹Uniqueness of the Smith normal form›
theory SNF_Uniqueness
imports
Cauchy_Binet
Smith_Normal_Form_JNF
Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin
lemma dvd_associated1:
fixes a::"'a::comm_ring_1"
assumes "∃u. u dvd 1 ∧ a = u*b"
shows "a dvd b ∧ b dvd a"
using assms by auto
text ‹This is a key lemma. It demands the type class to be an integral domain. This means that
the uniqueness result will be obtained for GCD domains, instead of rings.›
lemma dvd_associated2:
fixes a::"'a::idom"
assumes ab: "a dvd b" and ba: "b dvd a" and a: "a≠0"
shows "∃u. u dvd 1 ∧ a = u*b"
proof -
obtain k where a_kb: "a = k*b" using ab unfolding dvd_def
by (metis Groups.mult_ac(2) ba dvdE)
obtain q where b_qa: "b = q*a" using ba unfolding dvd_def
by (metis Groups.mult_ac(2) ab dvdE)
have 1: "a = k*q*a" using a_kb b_qa by auto
hence "k*q = 1" using a by simp
thus ?thesis using 1 by (metis a_kb dvd_triv_left)
qed
corollary dvd_associated:
fixes a::"'a::idom"
assumes "a≠0"
shows "(a dvd b ∧ b dvd a) = (∃u. u dvd 1 ∧ a = u*b)"
using assms dvd_associated1 dvd_associated2 by metis
lemma exists_inj_ge_index:
assumes S: "S ⊆ {0..<n}" and Sk: "card S = k"
shows "∃f. inj_on f {0..<k} ∧ f`{0..<k} = S ∧ (∀i∈{0..<k}. i ≤ f i)"
proof -
have "∃h. bij_betw h {0..<k} S"
using S Sk ex_bij_betw_nat_finite subset_eq_atLeast0_lessThan_finite by blast
from this obtain g where inj_on_g: "inj_on g {0..<k}" and gk_S: "g`{0..<k} = S"
unfolding bij_betw_def by blast
let ?f = "strict_from_inj k g"
have "strict_mono_on ?f {0..<k}" by (rule strict_strict_from_inj[OF inj_on_g])
hence 1: "inj_on ?f {0..<k}" using strict_mono_on_imp_inj_on by blast
have 2: "?f`{0..<k} = S" by (simp add: strict_from_inj_image' inj_on_g gk_S)
have 3: "∀i∈{0..<k}. i ≤ ?f i"
proof
fix i assume i: "i ∈ {0..<k}"
let ?xs = "sorted_list_of_set (g`{0..<k})"
have "strict_from_inj k g i = ?xs ! i" unfolding strict_from_inj_def using i by auto
moreover have "i ≤ ?xs ! i"
proof (rule sorted_wrt_less_idx, rule sorted_distinct_imp_sorted_wrt)
show "sorted ?xs"
using sorted_sorted_list_of_set by blast
show "distinct ?xs" using distinct_sorted_list_of_set by blast
show "i < length ?xs"
by (metis S Sk atLeast0LessThan distinct_card distinct_sorted_list_of_set gk_S i
lessThan_iff set_sorted_list_of_set subset_eq_atLeast0_lessThan_finite)
qed
ultimately show "i ≤ ?f i" by auto
qed
show ?thesis using 1 2 3 by auto
qed
subsection ‹More specific results about submatrices›
lemma diagonal_imp_submatrix0:
assumes dA: "diagonal_mat A" and A_carrier: "A∈ carrier_mat n m"
and Ik: "card I = k" and Jk: "card J = k"
and r: "∀row_index ∈ I. row_index < n"
and c: "∀col_index ∈ J. col_index < m"
and a: "a<k" and b: "b<k"
shows "submatrix A I J $$ (a, b) = 0 ∨ submatrix A I J $$ (a,b) = A $$(pick I a, pick I a)"
proof (cases "submatrix A I J $$ (a, b) = 0")
case True
then show ?thesis by auto
next
case False note not0 = False
have aux: "submatrix A I J $$ (a, b) = A $$(pick I a, pick J b)"
proof (rule submatrix_index)
have "card {i. i < dim_row A ∧ i ∈ I} = k"
by (smt A_carrier Ik carrier_matD(1) equalityI mem_Collect_eq r subsetI)
moreover have "card {i. i < dim_col A ∧ i ∈ J} = k"
by (metis (no_types, lifting) A_carrier Jk c carrier_matD(2) carrier_mat_def
equalityI mem_Collect_eq subsetI)
ultimately show " a < card {i. i < dim_row A ∧ i ∈ I}"
and "b < card {i. i < dim_col A ∧ i ∈ J}" using a b by auto
qed
thus ?thesis
proof (cases "pick I a = pick J b")
case True
then show ?thesis using aux by auto
next
case False
then show ?thesis
by (metis aux A_carrier Ik Jk a b c carrier_matD dA diagonal_mat_def pick_in_set_le r)
qed
qed
lemma diagonal_imp_submatrix_element_not0:
assumes dA: "diagonal_mat A"
and A_carrier: "A ∈ carrier_mat n m"
and Ik: "card I = k" and Jk: "card J = k"
and I: "I ⊆ {0..<n}"
and J: "J ⊆ {0..<m}"
and b: "b < k"
and ex_not0: "∃i. i<k ∧ submatrix A I J $$ (i, b) ≠ 0"
shows "∃!i. i<k ∧ submatrix A I J $$ (i, b) ≠ 0"
proof -
have I_eq: "I = {i. i < dim_row A ∧ i ∈ I}" using I A_carrier unfolding carrier_mat_def by auto
have J_eq: "J = {i. i < dim_col A ∧ i ∈ J}" using J A_carrier unfolding carrier_mat_def by auto
obtain a where sub_ab: "submatrix A I J $$ (a, b) ≠ 0" and ak: "a < k" using ex_not0 by auto
moreover have "i = a" if sub_ib: "submatrix A I J $$ (i, b) ≠ 0" and ik: "i < k" for i
proof -
have 1: "pick I i < dim_row A"
using I_eq Ik ik pick_in_set_le by auto
have 2: "pick J b < dim_col A"
using J_eq Jk b pick_le by auto
have 3: "pick I a < dim_row A"
using I_eq Ik calculation(2) pick_le by auto
have "submatrix A I J $$ (i, b) = A $$ (pick I i, pick J b)"
by (rule submatrix_index, insert I_eq Ik ik J_eq Jk b, auto)
hence pick_Ii_Jb: "pick I i = pick J b" using dA sub_ib 1 2 unfolding diagonal_mat_def by auto
have "submatrix A I J $$ (a, b) = A $$ (pick I a, pick J b)"
by (rule submatrix_index, insert I_eq Ik ak J_eq Jk b, auto)
hence pick_Ia_Jb: "pick I a = pick J b" using dA sub_ab 3 2 unfolding diagonal_mat_def by auto
have pick_Ia_Ii: "pick I a = pick I i" using pick_Ii_Jb pick_Ia_Jb by simp
thus ?thesis by (metis Ik ak ik nat_neq_iff pick_mono_le)
qed
ultimately show ?thesis by auto
qed
lemma submatrix_index_exists:
assumes A_carrier: "A∈ carrier_mat n m"
and Ik: "card I = k" and Jk: "card J = k"
and a: "a ∈ I" and b: "b ∈ J" and k: "k > 0"
and I: "I ⊆ {0..<n}" and J: "J ⊆ {0..<m}"
shows "∃a' b'. a' < k ∧ b' < k ∧ submatrix A I J $$ (a',b') = A $$ (a,b)
∧ a = pick I a' ∧ b = pick J b'"
proof -
let ?xs = "sorted_list_of_set I"
let ?ys = "sorted_list_of_set J"
have finI: "finite I" and finJ: "finite J" using k Ik Jk card_ge_0_finite by metis+
have set_xs: "set ?xs = I" by (rule set_sorted_list_of_set[OF finI])
have set_ys: "set ?ys = J" by (rule set_sorted_list_of_set[OF finJ])
have a_in_xs: "a ∈ set ?xs" and b_in_ys: "b ∈ set ?ys" using set_xs a set_ys b by auto
have length_xs: "length ?xs = k" by (metis Ik distinct_card set_xs sorted_list_of_set(3))
have length_ys: "length ?ys = k" by (metis Jk distinct_card set_ys sorted_list_of_set(3))
obtain a' where a': "?xs ! a' = a" and a'_length: "a' < length ?xs"
by (meson a_in_xs in_set_conv_nth)
obtain b' where b': "?ys ! b' = b" and b'_length: "b' < length ?ys"
by (meson b_in_ys in_set_conv_nth)
have pick_a: "a = pick I a'" using a' a'_length finI sorted_list_of_set_eq_pick by auto
have pick_b: "b = pick J b'" using b' b'_length finJ sorted_list_of_set_eq_pick by auto
have I_rw: "I = {i. i < dim_row A ∧ i ∈ I}" and J_rw: "J = {i. i < dim_col A ∧ i ∈ J}"
using I A_carrier J by auto
have a'k: "a' < k" using a'_length length_xs by auto
moreover have b'k: "b'<k" using b'_length length_ys by auto
moreover have sub_eq: "submatrix A I J $$ (a', b') = A $$ (a, b)"
unfolding pick_a pick_b
by (rule submatrix_index, insert J_rw I_rw Ik Jk a'_length length_xs b'_length length_ys, auto)
ultimately show ?thesis using pick_a pick_b by auto
qed
lemma mat_delete_submatrix_insert:
assumes A_carrier: "A ∈ carrier_mat n m"
and Ik: "card I = k" and Jk: "card J = k"
and I: "I ⊆ {0..<n}" and J: "J ⊆ {0..<m}"
and a: "a < n" and b: "b < m"
and k: "k < min n m"
and a_notin_I: "a ∉ I" and b_notin_J: "b ∉ J"
and a'k: "a' < Suc k" and b'k: "b' < Suc k"
and a_def: "pick (insert a I) a' = a"
and b_def: "pick (insert b J) b' = b"
shows "mat_delete (submatrix A (insert a I) (insert b J)) a' b' = submatrix A I J" (is "?lhs = ?rhs")
proof (rule eq_matI)
have I_eq: "I = {i. i < dim_row A ∧ i ∈ I}"
using I A_carrier unfolding carrier_mat_def by auto
have J_eq: "J = {i. i < dim_col A ∧ i ∈ J}"
using J A_carrier unfolding carrier_mat_def by auto
have insert_I_eq: "insert a I = {i. i < dim_row A ∧ i ∈ insert a I}"
using I A_carrier a k unfolding carrier_mat_def by auto
have card_Suc_k: "card {i. i < dim_row A ∧ i ∈ insert a I} = Suc k"
using insert_I_eq Ik a_notin_I
by (metis I card_insert_disjoint finite_atLeastLessThan finite_subset)
have insert_J_eq: "insert b J = {i. i < dim_col A ∧ i ∈ insert b J}"
using J A_carrier b k unfolding carrier_mat_def by auto
have card_Suc_k': "card {i. i < dim_col A ∧ i ∈ insert b J} = Suc k"
using insert_J_eq Jk b_notin_J
by (metis J card_insert_disjoint finite_atLeastLessThan finite_subset)
show "dim_row ?lhs = dim_row ?rhs"
unfolding mat_delete_dim unfolding dim_submatrix using card_Suc_k I_eq Ik by auto
show "dim_col ?lhs = dim_col ?rhs"
unfolding mat_delete_dim unfolding dim_submatrix using card_Suc_k' J_eq Jk by auto
fix i j assume i: "i < dim_row (submatrix A I J)"
and j: "j < dim_col (submatrix A I J)"
have ik: "i < k" by (metis I_eq Ik dim_submatrix(1) i)
have jk: "j < k" by (metis J_eq Jk dim_submatrix(2) j)
show "?lhs $$ (i, j) = ?rhs $$ (i, j)"
proof -
have index_eq1: "pick (insert a I) (insert_index a' i) = pick I i"
by (rule pick_insert_index[OF Ik a_notin_I ik a_def], simp add: Ik a'k)
have index_eq2: "pick (insert b J) (insert_index b' j) = pick J j"
by (rule pick_insert_index[OF Jk b_notin_J jk b_def], simp add: Jk b'k)
have "?lhs $$ (i,j)
= (submatrix A (insert a I) (insert b J)) $$ (insert_index a' i, insert_index b' j)"
proof (rule mat_delete_index[symmetric, OF _ a'k b'k ik jk])
show "submatrix A (insert a I) (insert b J) ∈ carrier_mat (Suc k) (Suc k)"
by (metis card_Suc_k card_Suc_k' carrier_matI dim_submatrix(1) dim_submatrix(2))
qed
also have "... = A $$ (pick (insert a I) (insert_index a' i), pick (insert b J) (insert_index b' j))"
proof (rule submatrix_index)
show "insert_index a' i < card {i. i < dim_row A ∧ i ∈ insert a I}"
using card_Suc_k ik insert_index_def by auto
show "insert_index b' j < card {j. j < dim_col A ∧ j ∈ insert b J}"
using card_Suc_k' insert_index_def jk by auto
qed
also have "... = A $$ (pick I i, pick J j)" unfolding index_eq1 index_eq2 by auto
also have "... = submatrix A I J $$ (i,j)"
by (rule submatrix_index[symmetric], insert ik I_eq Ik Jk J_eq jk, auto)
finally show ?thesis .
qed
qed
subsection ‹On the minors of a diagonal matrix›
lemma det_minors_diagonal:
assumes dA: "diagonal_mat A" and A_carrier: "A ∈ carrier_mat n m"
and Ik: "card I = k" and Jk: "card J = k"
and r: "I ⊆ {0..<n}"
and c: "J ⊆ {0..<m}" and k: "k>0"
shows "det (submatrix A I J) = 0
∨ (∃xs. (det (submatrix A I J) = prod_list xs ∨ det (submatrix A I J) = - prod_list xs)
∧ set xs ⊆ {A$$(i,i)|i. i<min n m ∧ A$$(i,i)≠ 0} ∧ length xs = k)"
using Ik Jk r c k
proof (induct k arbitrary: I J)
case 0
then show ?case by auto
next
case (Suc k)
note cardI = Suc.prems(1)
note cardJ = Suc.prems(2)
note I = Suc.prems(3)
note J = Suc.prems(4)
have *: "{i. i < dim_row A ∧ i ∈ I} = I" using I Ik A_carrier carrier_mat_def by auto
have **: "{j. j < dim_col A ∧ j ∈ J} = J" using J Jk A_carrier carrier_mat_def by auto
show ?case
proof (cases "k = 0")
case True note k0 = True
from this obtain a where aI: "I = {a}" using True cardI card_1_singletonE by auto
from this obtain b where bJ: "J = {b}" using True cardJ card_1_singletonE by auto
have an: "a<n" using aI I by auto
have bm: "b<m" using bJ J by auto
have sub_carrier: "submatrix A {a} {b} ∈ carrier_mat 1 1"
unfolding carrier_mat_def submatrix_def
using * ** aI bJ by auto
have 1: "det (submatrix A {a} {b}) = (submatrix A {a} {b}) $$ (0,0)"
by (rule det_singleton[OF sub_carrier])
have 2: "... = A $$ (a,b)"
by (rule submatrix_singleton_index[OF A_carrier an bm])
show ?thesis
proof (cases "A $$ (a,b) ≠ 0")
let ?xs = "[submatrix A {a} {b} $$ (0,0)]"
case True
hence "a = b" using dA A_carrier an bm unfolding diagonal_mat_def carrier_mat_def by auto
hence "set ?xs ⊆ {A $$ (i, i) |i. i < min n m ∧ A $$ (i, i) ≠ 0}"
using 2 True an bm by auto
moreover have "det (submatrix A {a} {b}) = prod_list ?xs" using 1 by auto
moreover have "length ?xs = Suc k" using k0 by auto
ultimately show ?thesis using an bm unfolding aI bJ by blast
next
case False
then show ?thesis using 1 2 aI bJ by auto
qed
next
case False
hence k0: "0 < k" by simp
have k: "k < min n m"
by (metis I J cardI cardJ le_imp_less_Suc less_Suc_eq_le min.commute
min_def not_less subset_eq_atLeast0_lessThan_card)
have subIJ_carrier: "(submatrix A I J) ∈ carrier_mat (Suc k) (Suc k)"
unfolding carrier_mat_def using * ** cardI cardJ
unfolding submatrix_def by auto
obtain b' where b'k: "b' < Suc k" by auto
let ?f="λi. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b'"
have det_rw: "det (submatrix A I J)
= (∑i<Suc k. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b')"
by (rule laplace_expansion_column[OF subIJ_carrier b'k])
show ?thesis
proof (cases "∃a'<Suc k. submatrix A I J $$ (a',b') ≠ 0")
case True
obtain a' where sub_IJ_0: "submatrix A I J $$ (a',b') ≠ 0"
and a'k: "a' < Suc k"
and unique: "∀j. j<Suc k ∧ submatrix A I J $$ (j,b') ≠ 0 ⟶ j = a'"
using diagonal_imp_submatrix_element_not0[OF dA A_carrier cardI cardJ I J b'k True] by auto
have "submatrix A I J $$ (a', b') = A $$ (pick I a', pick J b')"
by (rule submatrix_index, auto simp add: "*" a'k cardI "**" b'k cardJ)
from this obtain a b where an: "a < n" and bm: "b < m"
and sub_index: "submatrix A I J $$ (a', b') = A $$ (a, b)"
and pick_a: "pick I a' = a" and pick_b: "pick J b' = b"
using * ** A_carrier a'k b'k cardI cardJ pick_le by fastforce
obtain I' where aI': "I = insert a I'" and a_notin: "a ∉ I'"
by (metis Set.set_insert a'k cardI pick_a pick_in_set_le)
obtain J' where bJ': "J = insert b J'" and b_notin: "b ∉ J'"
by (metis Set.set_insert b'k cardJ pick_b pick_in_set_le)
have Suc_k0: "0 < Suc k" by simp
have aI: "a ∈ I" using aI' by auto
have bJ: "b ∈ J" using bJ' by auto
have cardI': "card I' = k"
by (metis aI' a_notin cardI card.infinite card_insert_disjoint
finite_insert nat.inject nat.simps(3))
have cardJ': "card J' = k"
by (metis bJ' b_notin cardJ card.infinite card_insert_disjoint
finite_insert nat.inject nat.simps(3))
have I': "I' ⊆ {0..<n}" using I aI' by blast
have J': "J' ⊆ {0..<m}" using J bJ' by blast
have det_sub_I'J': "Determinant.det (submatrix A I' J') = 0 ∨
(∃xs. (det (submatrix A I' J') = prod_list xs ∨ det (submatrix A I' J') = - prod_list xs)
∧ set xs ⊆ {A $$ (i, i) |i. i < min n m ∧ A $$ (i, i) ≠ 0} ∧ length xs = k)"
proof (rule Suc.hyps[OF cardI' cardJ' _ _ k0])
show "I' ⊆ {0..<n}" using I aI' by blast
show "J' ⊆ {0..<m}" using J bJ' by blast
qed
have mat_delete_sub:
"mat_delete (submatrix A (insert a I') (insert b J')) a' b' = submatrix A I' J'"
by (rule mat_delete_submatrix_insert[OF A_carrier cardI' cardJ' I' J' an bm k
a_notin b_notin a'k b'k],insert pick_a pick_b aI' bJ', auto)
have set_rw: "{0..<Suc k} = insert a' ({0..<Suc k}-{a'})"
by (simp add: a'k insert_absorb)
have rw0: "sum ?f ({0..<Suc k}-{a'}) = 0" by (rule sum.neutral, insert unique, auto)
have "det (submatrix A I J)
= (∑i<Suc k. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b')"
by (rule laplace_expansion_column[OF subIJ_carrier b'k])
also have "... = ?f a' + sum ?f ({0..<Suc k}-{a'})"
by (metis (no_types, lifting) Diff_iff atLeast0LessThan finite_atLeastLessThan
finite_insert set_rw singletonI sum.insert)
also have "... = ?f a'" using rw0 unfolding cofactor_def by auto
also have "... = submatrix A I J $$ (a', b') * ((-1) ^ (a' + b') * det (submatrix A I' J'))"
unfolding cofactor_def using mat_delete_sub aI' bJ' by simp
finally have det_submatrix_IJ: "det (submatrix A I J)
= A $$ (a, b) * ((- 1) ^ (a' + b') * det (submatrix A I' J'))" unfolding sub_index .
show ?thesis
proof (cases "det (submatrix A I' J') = 0")
case True
then show ?thesis using det_submatrix_IJ by auto
next
case False note det_not0 = False
from this obtain xs where prod_list_xs: "det (submatrix A I' J') = prod_list xs
∨ det (submatrix A I' J') = - prod_list xs"
and xs: "set xs ⊆ {A $$ (i, i) |i. i < min n m ∧ A $$ (i, i) ≠ 0}"
and length_xs: "length xs = k"
using det_sub_I'J' by blast
let ?ys = "A$$(a,b) # xs"
have length_ys: "length ?ys = Suc k" using length_xs by auto
have a_eq_b: "a=b"
using A_carrier an bm sub_IJ_0 sub_index dA unfolding diagonal_mat_def by auto
have A_aa_in: "A$$(a,a) ∈ {A $$ (i, i) |i. i < min n m ∧ A $$ (i, i) ≠ 0}"
using a_eq_b an bm sub_IJ_0 sub_index by auto
have ys: "set ?ys ⊆ {A $$ (i, i) |i. i < min n m ∧ A $$ (i, i) ≠ 0}"
using xs A_aa_in a_eq_b by auto
show ?thesis
proof (cases "even (a'+b')")
case True
have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * det (submatrix A I' J')"
using det_submatrix_IJ True by auto
show ?thesis
proof (cases "det (submatrix A I' J') = prod_list xs")
case True
have "det (submatrix A I J) = prod_list ?ys"
using det_submatrix_IJ unfolding True by auto
then show ?thesis using ys length_ys by blast
next
case False
hence "det (submatrix A I' J') = - prod_list xs" using prod_list_xs by simp
hence "det (submatrix A I J) = - prod_list ?ys" using det_submatrix_IJ by auto
then show ?thesis using ys length_ys by blast
qed
next
case False
have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * - det (submatrix A I' J')"
using det_submatrix_IJ False by auto
show ?thesis
proof (cases "det (submatrix A I' J') = prod_list xs")
case True
have "det (submatrix A I J) = - prod_list ?ys"
using det_submatrix_IJ unfolding True by auto
then show ?thesis using ys length_ys by blast
next
case False
hence "det (submatrix A I' J') = - prod_list xs" using prod_list_xs by simp
hence "det (submatrix A I J) = prod_list ?ys" using det_submatrix_IJ by auto
then show ?thesis using ys length_ys by blast
qed
qed
qed
next
case False
have "sum ?f {0..<Suc k} = 0" by (rule sum.neutral, insert False, auto)
thus ?thesis using det_rw
by (simp add: atLeast0LessThan)
qed
qed
qed
definition "minors A k = {det (submatrix A I J)| I J. I ⊆ {0..<dim_row A}
∧ J ⊆ {0..<dim_col A} ∧ card I = k ∧ card J = k}"
lemma Gcd_minors_dvd:
fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
assumes PAQ_B: "P * A * Q = B"
and P: "P ∈ carrier_mat m m"
and A: "A ∈ carrier_mat m n"
and Q: "Q ∈ carrier_mat n n"
and I: "I ⊆ {0..<dim_row A}" and J: "J ⊆ {0..<dim_col A}"
and Ik: "card I = k" and Jk: "card J = k"
shows "Gcd (minors A k) dvd det (submatrix B I J)"
proof -
let ?subPA = "submatrix (P * A) I UNIV"
let ?subQ = "submatrix Q UNIV J"
have subPA: "?subPA ∈ carrier_mat k n"
proof -
have "I = {i. i < dim_row P ∧ i ∈ I}" using P I A by auto
hence "card {i. i < dim_row P ∧ i ∈ I} = k" using Ik by auto
thus ?thesis using A unfolding submatrix_def by auto
qed
have subQ: "submatrix Q UNIV J ∈ carrier_mat n k"
proof -
have J_eq: "J = {j. j < dim_col Q ∧ j ∈ J}" using Q J A by auto
hence "card {j. j < dim_col Q ∧ j ∈ J} = k" using Jk by auto
moreover have "card {i. i < dim_row Q ∧ i ∈ UNIV} = n" using Q by auto
ultimately show ?thesis unfolding submatrix_def by auto
qed
have sub_sub_PA: "(submatrix ?subPA UNIV I') = submatrix (P * A) I I'" for I'
using submatrix_split2[symmetric] by auto
have det_subPA_rw: "det (submatrix (P * A) I I') =
(∑J' | J' ⊆ {0..<m} ∧ card J' = k. det ((submatrix P I J')) * det (submatrix A J' I'))"
if I'1: "I' ⊆ {0..<n}" and I'2: "card I' = k" for I'
proof -
have "submatrix (P * A) I I' = submatrix P I UNIV * submatrix A UNIV I'"
unfolding submatrix_mult ..
also have "det ... = (∑C | C ⊆ {0..<m} ∧ card C = k.
det (submatrix (submatrix P I UNIV) UNIV C) * det (submatrix (submatrix A UNIV I') C UNIV))"
proof (rule Cauchy_Binet)
have "I = {i. i < dim_row P ∧ i ∈ I}" using P I A by auto
thus "submatrix P I UNIV ∈ carrier_mat k m" using Ik P unfolding submatrix_def by auto
have "I' = {j. j < dim_col A ∧ j ∈ I'}" using I'1 A by auto
thus "submatrix A UNIV I' ∈ carrier_mat m k" using I'2 A unfolding submatrix_def by auto
qed
also have "... = (∑J' | J' ⊆ {0..<m} ∧ card J' = k.
det (submatrix P I J') * det (submatrix A J' I'))"
unfolding submatrix_split2[symmetric] submatrix_split[symmetric] by simp
finally show ?thesis .
qed
have "det (submatrix B I J) = det (submatrix (P*A*Q) I J)" using PAQ_B by simp
also have "... = det (?subPA * ?subQ)" unfolding submatrix_mult by auto
also have "... = (∑I' | I' ⊆ {0..<n} ∧ card I' = k. det (submatrix ?subPA UNIV I')
* det (submatrix ?subQ I' UNIV))"
by (rule Cauchy_Binet[OF subPA subQ])
also have "... = (∑I' | I' ⊆ {0..<n} ∧ card I' = k.
det (submatrix (P * A) I I') * det (submatrix Q I' J))"
using submatrix_split[symmetric, of Q] submatrix_split2[symmetric, of "P*A"] by presburger
also have "... = (∑I' | I' ⊆ {0..<n} ∧ card I' = k. ∑J' | J' ⊆ {0..<m} ∧ card J' = k.
det (submatrix P I J') * det (submatrix A J' I') * det (submatrix Q I' J))"
using det_subPA_rw by (simp add: semiring_0_class.sum_distrib_right)
finally have det_rw: "det (submatrix B I J) = (∑I' | I' ⊆ {0..<n} ∧ card I' = k.
∑J' | J' ⊆ {0..<m} ∧ card J' = k.
det (submatrix P I J') * det (submatrix A J' I') * det (submatrix Q I' J))" .
show ?thesis
proof (unfold det_rw, (rule dvd_sum)+)
fix I' J'
assume I': "I' ∈ {I'. I' ⊆ {0..<n} ∧ card I' = k}"
and J': "J' ∈ {J'. J' ⊆ {0..<m} ∧ card J' = k}"
have "Gcd (minors A k) dvd det (submatrix A J' I')"
by (rule Gcd_dvd, unfold minors_def, insert A I' J', auto)
then show "Gcd (minors A k) dvd det (submatrix P I J') * det (submatrix A J' I')
* det (submatrix Q I' J)" by auto
qed
qed
lemma det_minors_diagonal2:
assumes dA: "diagonal_mat A" and A_carrier: "A ∈ carrier_mat n m"
and Ik: "card I = k" and Jk: "card J = k"
and r: "I ⊆ {0..<n}"
and c: "J ⊆ {0..<m}" and k: "k>0"
shows "det (submatrix A I J) = 0 ∨ (∃S. S ⊆ {0..<min n m} ∧ card S = k ∧ S=I ∧
(det (submatrix A I J) = (∏i∈S. A $$ (i,i)) ∨ det (submatrix A I J) = - (∏i∈S. A $$ (i,i))))"
using Ik Jk r c k
proof (induct k arbitrary: I J)
case 0
then show ?case by auto
next
case (Suc k)
note cardI = Suc.prems(1)
note cardJ = Suc.prems(2)
note I = Suc.prems(3)
note J = Suc.prems(4)
have *: "{i. i < dim_row A ∧ i ∈ I} = I" using I Ik A_carrier carrier_mat_def by auto
have **: "{j. j < dim_col A ∧ j ∈ J} = J" using J Jk A_carrier carrier_mat_def by auto
show ?case
proof (cases "k = 0")
case True note k0 = True
from this obtain a where aI: "I = {a}" using True cardI card_1_singletonE by auto
from this obtain b where bJ: "J = {b}" using True cardJ card_1_singletonE by auto
have an: "a<n" using aI I by auto
have bm: "b<m" using bJ J by auto
have sub_carrier: "submatrix A {a} {b} ∈ carrier_mat 1 1"
unfolding carrier_mat_def submatrix_def
using * ** aI bJ by auto
have 1: "det (submatrix A {a} {b}) = (submatrix A {a} {b}) $$ (0,0)"
by (rule det_singleton[OF sub_carrier])
have 2: "... = A $$ (a,b)"
by (rule submatrix_singleton_index[OF A_carrier an bm])
show ?thesis
proof (cases "A $$ (a,b) ≠ 0")
let ?S="{a}"
case True
hence ab: "a = b" using dA A_carrier an bm unfolding diagonal_mat_def carrier_mat_def by auto
hence "?S ⊆ {0..<min n m}" using an bm by auto
moreover have "det (submatrix A {a} {b}) = (∏i∈?S. A $$ (i, i))" using 1 2 ab by auto
moreover have "card ?S = Suc k" using k0 by auto
ultimately show ?thesis using an bm unfolding aI bJ by blast
next
case False
then show ?thesis using 1 2 aI bJ by auto
qed
next
case False
hence k0: "0 < k" by simp
have k: "k < min n m"
by (metis I J cardI cardJ le_imp_less_Suc less_Suc_eq_le min.commute
min_def not_less subset_eq_atLeast0_lessThan_card)
have subIJ_carrier: "(submatrix A I J) ∈ carrier_mat (Suc k) (Suc k)"
unfolding carrier_mat_def using * ** cardI cardJ
unfolding submatrix_def by auto
obtain b' where b'k: "b' < Suc k" by auto
let ?f="λi. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b'"
have det_rw: "det (submatrix A I J)
= (∑i<Suc k. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b')"
by (rule laplace_expansion_column[OF subIJ_carrier b'k])
show ?thesis
proof (cases "∃a'<Suc k. submatrix A I J $$ (a',b') ≠ 0")
case True
obtain a' where sub_IJ_0: "submatrix A I J $$ (a',b') ≠ 0"
and a'k: "a' < Suc k"
and unique: "∀j. j<Suc k ∧ submatrix A I J $$ (j,b') ≠ 0 ⟶ j = a'"
using diagonal_imp_submatrix_element_not0[OF dA A_carrier cardI cardJ I J b'k True] by auto
have "submatrix A I J $$ (a', b') = A $$ (pick I a', pick J b')"
by (rule submatrix_index, auto simp add: "*" a'k cardI "**" b'k cardJ)
from this obtain a b where an: "a < n" and bm: "b < m"
and sub_index: "submatrix A I J $$ (a', b') = A $$ (a, b)"
and pick_a: "pick I a' = a" and pick_b: "pick J b' = b"
using * ** A_carrier a'k b'k cardI cardJ pick_le by fastforce
obtain I' where aI': "I = insert a I'" and a_notin: "a ∉ I'"
by (metis Set.set_insert a'k cardI pick_a pick_in_set_le)
obtain J' where bJ': "J = insert b J'" and b_notin: "b ∉ J'"
by (metis Set.set_insert b'k cardJ pick_b pick_in_set_le)
have Suc_k0: "0 < Suc k" by simp
have aI: "a ∈ I" using aI' by auto
have bJ: "b ∈ J" using bJ' by auto
have cardI': "card I' = k"
by (metis aI' a_notin cardI card.infinite card_insert_disjoint
finite_insert nat.inject nat.simps(3))
have cardJ': "card J' = k"
by (metis bJ' b_notin cardJ card.infinite card_insert_disjoint
finite_insert nat.inject nat.simps(3))
have I': "I' ⊆ {0..<n}" using I aI' by blast
have J': "J' ⊆ {0..<m}" using J bJ' by blast
have det_sub_I'J': "det (submatrix A I' J') = 0 ∨ (∃S⊆{0..<min n m}. card S = k ∧ S=I'
∧ (det (submatrix A I' J') = (∏i∈S. A $$ (i, i))
∨ det (submatrix A I' J') = - (∏i∈S. A $$ (i, i))))"
proof (rule Suc.hyps[OF cardI' cardJ' _ _ k0])
show "I' ⊆ {0..<n}" using I aI' by blast
show "J' ⊆ {0..<m}" using J bJ' by blast
qed
have mat_delete_sub:
"mat_delete (submatrix A (insert a I') (insert b J')) a' b' = submatrix A I' J'"
by (rule mat_delete_submatrix_insert[OF A_carrier cardI' cardJ' I' J' an bm k
a_notin b_notin a'k b'k],insert pick_a pick_b aI' bJ', auto)
have set_rw: "{0..<Suc k} = insert a' ({0..<Suc k}-{a'})"
by (simp add: a'k insert_absorb)
have rw0: "sum ?f ({0..<Suc k}-{a'}) = 0" by (rule sum.neutral, insert unique, auto)
have "det (submatrix A I J)
= (∑i<Suc k. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b')"
by (rule laplace_expansion_column[OF subIJ_carrier b'k])
also have "... = ?f a' + sum ?f ({0..<Suc k}-{a'})"
by (metis (no_types, lifting) Diff_iff atLeast0LessThan finite_atLeastLessThan
finite_insert set_rw singletonI sum.insert)
also have "... = ?f a'" using rw0 unfolding cofactor_def by auto
also have "... = submatrix A I J $$ (a', b') * ((-1) ^ (a' + b') * det (submatrix A I' J'))"
unfolding cofactor_def using mat_delete_sub aI' bJ' by simp
finally have det_submatrix_IJ: "det (submatrix A I J)
= A $$ (a, b) * ((- 1) ^ (a' + b') * det (submatrix A I' J'))" unfolding sub_index .
show ?thesis
proof (cases "det (submatrix A I' J') = 0")
case True
then show ?thesis using det_submatrix_IJ by auto
next
case False note det_not0 = False
from this obtain xs where prod_list_xs: "det (submatrix A I' J') = (∏i∈xs. A $$ (i, i))
∨ det (submatrix A I' J') = - (∏i∈xs. A $$ (i, i))"
and xs: "xs⊆{0..<min n m}"
and length_xs: "card xs = k"
and xs_I': "xs=I'"
using det_sub_I'J' by blast
let ?ys = "insert a xs"
have a_notin_xs: "a ∉ xs"
by (simp add: xs_I' a_notin)
have length_ys: "card ?ys = Suc k"
using length_xs a_notin_xs by (simp add: card_ge_0_finite k0)
have a_eq_b: "a=b"
using A_carrier an bm sub_IJ_0 sub_index dA unfolding diagonal_mat_def by auto
have A_aa_in: "A$$(a,a) ∈ {A $$ (i, i) |i. i < min n m ∧ A $$ (i, i) ≠ 0}"
using a_eq_b an bm sub_IJ_0 sub_index by auto
show ?thesis
proof (cases "even (a'+b')")
case True
have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * det (submatrix A I' J')"
using det_submatrix_IJ True by auto
show ?thesis
proof (cases "det (submatrix A I' J') = (∏i∈xs. A $$ (i, i))")
case True
have "det (submatrix A I J) = (∏i∈?ys. A $$ (i, i))"
using det_submatrix_IJ unfolding True a_eq_b
by (metis (no_types, lifting) a_notin_xs a_eq_b
card_ge_0_finite k0 length_xs prod.insert)
then show ?thesis using length_ys
using a_eq_b an bm xs xs_I'
by (simp add: aI')
next
case False
hence "det (submatrix A I' J') = - (∏i∈xs. A $$ (i, i))" using prod_list_xs by simp
hence "det (submatrix A I J) = -(∏i∈?ys. A $$ (i, i))" using det_submatrix_IJ a_eq_b
by (metis (no_types, lifting) a_notin_xs card_ge_0_finite k0
length_xs mult_minus_right prod.insert)
then show ?thesis using length_ys
using a_eq_b an bm xs aI' xs_I' by force
qed
next
case False
have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * - det (submatrix A I' J')"
using det_submatrix_IJ False by auto
show ?thesis
proof (cases "det (submatrix A I' J') = (∏i∈xs. A $$ (i, i))")
case True
have "det (submatrix A I J) = - (∏i∈?ys. A $$ (i, i))"
using det_submatrix_IJ unfolding True
by (metis (no_types, lifting) a_eq_b a_notin_xs card_ge_0_finite k0
length_xs mult_minus_right prod.insert)
then show ?thesis using length_ys
using a_eq_b an bm xs aI' xs_I' by force
next
case False
hence "det (submatrix A I' J') = - (∏i∈xs. A $$ (i, i))" using prod_list_xs by simp
hence "det (submatrix A I J) = (∏i∈?ys. A $$ (i, i))" using det_submatrix_IJ
by (metis (mono_tags, lifting) a_eq_b a_notin_xs card_ge_0_finite
equation_minus_iff k0 length_xs prod.insert)
then show ?thesis using length_ys
using a_eq_b an bm xs aI' xs_I' by force
qed
qed
qed
next
case False
have "sum ?f {0..<Suc k} = 0" by (rule sum.neutral, insert False, auto)
thus ?thesis using det_rw
by (simp add: atLeast0LessThan)
qed
qed
qed
subsection ‹Relating minors and GCD›
lemma diagonal_dvd_Gcd_minors:
fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
assumes A: "A ∈ carrier_mat n m"
and SNF_A: "Smith_normal_form_mat A"
shows "(∏i=0..<k. A $$ (i,i)) dvd Gcd (minors A k)"
proof (cases "k=0")
case True
then show ?thesis by auto
next
case False
hence k: "0<k" by simp
show ?thesis
proof (rule Gcd_greatest)
have diag_A: "diagonal_mat A"
using SNF_A unfolding Smith_normal_form_mat_def isDiagonal_mat_def diagonal_mat_def by auto
fix b assume b_in_minors: "b ∈ minors A k"
show "(∏i = 0..<k. A $$ (i, i)) dvd b"
proof (cases "b=0")
case True
then show ?thesis by auto
next
case False
obtain I J where b: "b = det (submatrix A I J)" and I: "I ⊆ {0..<dim_row A} "
and J: "J ⊆ {0..<dim_col A}" and Ik: "card I = k" and Jk: "card J = k"
using b_in_minors unfolding minors_def by blast
obtain S where S: "S ⊆ {0..<min n m}" and Sk: "card S = k"
and det_subS: "det (submatrix A I J) = (∏i∈S. A $$ (i,i))
∨ det (submatrix A I J) = -(∏i∈S. A $$ (i,i))"
using det_minors_diagonal2[OF diag_A A Ik Jk _ _ k] I J A False b by auto
obtain f where inj_f: "inj_on f {0..<k}" and fk_S: "f`{0..<k} = S"
and i_fi: " (∀i∈{0..<k}. i ≤ f i)" using exists_inj_ge_index[OF S Sk] by blast
have "(∏i = 0..<k. A $$ (i, i)) dvd (∏i∈{0..<k}. A $$ (f i,f i))"
by (rule prod_dvd_prod, rule SNF_divides_diagonal[OF A SNF_A], insert fk_S S i_fi, force+)
also have "... = (∏i∈f`{0..<k}. A $$ (i,i))"
by (rule prod.reindex[symmetric, unfolded o_def, OF inj_f])
also have "... = (∏i∈S. A $$ (i, i))" using fk_S by auto
finally have *: "(∏i = 0..<k. A $$ (i, i)) dvd (∏i∈S. A $$ (i, i))" .
show "(∏i = 0..<k. A $$ (i, i)) dvd b" using det_subS b * by auto
qed
qed
qed
lemma Gcd_minors_dvd_diagonal:
fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
assumes A: "A ∈ carrier_mat n m"
and SNF_A: "Smith_normal_form_mat A"
and k: "k ≤ min n m"
shows "Gcd (minors A k) dvd (∏i=0..<k. A $$ (i,i))"
proof (rule Gcd_dvd)
define I where "I = {0..<k}"
have "(∏i = 0..<k. A $$ (i, i)) = det (submatrix A I I)"
proof -
have sub_eq: "submatrix A I I = mat k k (λ(i, j). A $$ (i, j))"
proof (rule eq_matI, auto)
have "I = {i. i < dim_row A ∧ i ∈ I}" unfolding I_def using A k by auto
hence ck: "card {i. i < dim_row A ∧ i ∈ I} = k"
unfolding I_def using card_atLeastLessThan by presburger
have "I = {i. i < dim_col A ∧ i ∈ I}" unfolding I_def using A k by auto
hence ck2: "card {j. j < dim_col A ∧ j ∈ I} = k"
unfolding I_def using card_atLeastLessThan by presburger
show dr: "dim_row (submatrix A I I) = k" using ck unfolding submatrix_def by auto
show dc: "dim_col (submatrix A I I) = k" using ck2 unfolding submatrix_def by auto
fix i j assume i: "i < k" and j: "j < k"
have p1: "pick I i = i"
proof -
have "{0..<i} = {a ∈ I. a < i}" using I_def i by auto
hence i_eq: "i = card {a ∈ I. a < i}"
by (metis card_atLeastLessThan diff_zero)
have "pick I i = pick I (card {a ∈ I. a < i})" using i_eq by simp
also have "... = i" by (rule pick_card_in_set, insert i I_def, simp)
finally show ?thesis .
qed
have p2: "pick I j = j"
proof -
have "{0..<j} = {a ∈ I. a < j}" using I_def j by auto
hence j_eq: "j = card {a ∈ I. a < j}"
by (metis card_atLeastLessThan diff_zero)
have "pick I j = pick I (card {a ∈ I. a < j})" using j_eq by simp
also have "... = j" by (rule pick_card_in_set, insert j I_def, simp)
finally show ?thesis .
qed
have "submatrix A I I $$ (i, j) = A $$ (pick I i, pick I j)"
proof (rule submatrix_index)
show "i < card {i. i < dim_row A ∧ i ∈ I}" by (metis dim_submatrix(1) dr i)
show "j < card {j. j < dim_col A ∧ j ∈ I}" by (metis dim_submatrix(2) dc j)
qed
also have "... = A $$ (i,j)" using p1 p2 by simp
finally show "submatrix A I I $$ (i, j) = A $$ (i, j)" .
qed
hence "det (submatrix A I I) = det (mat k k (λ(i, j). A $$ (i, j)))" by simp
also have "... = prod_list (diag_mat (mat k k (λ(i, j). A $$ (i, j))))"
proof (rule det_upper_triangular)
show "mat k k (λ(i, j). A $$ (i, j)) ∈ carrier_mat k k" by auto
show "upper_triangular (Matrix.mat k k (λ(i, j). A $$ (i, j)))"
using SNF_A A k unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto
qed
also have "... = (∏i = 0..<k. A $$ (i, i))"
by (metis (mono_tags, lifting) atLeastLessThan_iff dim_row_mat(1) index_mat(1)
prod.cong prod_list_diag_prod split_conv)
finally show ?thesis ..
qed
moreover have "I ⊆ {0..<dim_row A}" using k A I_def by auto
moreover have "I ⊆ {0..<dim_col A}" using k A I_def by auto
moreover have "card I = k" using I_def by auto
ultimately show "(∏i = 0..<k. A $$ (i, i)) ∈ minors A k" unfolding minors_def by auto
qed
lemma Gcd_minors_A_dvd_Gcd_minors_PAQ:
fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
assumes A: "A ∈ carrier_mat m n"
and P: "P ∈ carrier_mat m m" and Q: "Q ∈ carrier_mat n n"
shows "Gcd (minors A k) dvd Gcd (minors (P*A*Q) k)"
proof (rule Gcd_greatest)
let ?B="(P * A * Q)"
fix b assume "b ∈ minors ?B k"
from this obtain I J where b: "b = det (submatrix ?B I J)" and I: "I ⊆ {0..<dim_row ?B}"
and J: "J ⊆ {0..<dim_col ?B}" and Ik: "card I = k" and Jk: "card J = k"
unfolding minors_def by blast
have "Gcd (minors A k) dvd det (submatrix ?B I J)"
by (rule Gcd_minors_dvd[OF _ P A Q _ _ Ik Jk], insert A I J P Q, auto)
thus "Gcd (minors A k) dvd b" using b by simp
qed
lemma Gcd_minors_PAQ_dvd_Gcd_minors_A:
fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
assumes A: "A ∈ carrier_mat m n"
and P: "P ∈ carrier_mat m m"
and Q: "Q ∈ carrier_mat n n"
and inv_P: "invertible_mat P"
and inv_Q: "invertible_mat Q"
shows "Gcd (minors (P*A*Q) k) dvd Gcd (minors A k)"
proof (rule Gcd_greatest)
let ?B = "P * A * Q"
fix b assume "b ∈ minors A k"
from this obtain I J where b: "b = det (submatrix A I J)" and I: "I ⊆ {0..<dim_row A} "
and J: "J ⊆ {0..<dim_col A}" and Ik: "card I = k" and Jk: "card J = k"
unfolding minors_def by blast
obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P"
using inv_P unfolding invertible_mat_def by auto
obtain Q' where QQ': "inverts_mat Q Q'" and Q'Q: "inverts_mat Q' Q"
using inv_Q unfolding invertible_mat_def by auto
have P': "P' ∈ carrier_mat m m" using PP' P'P unfolding inverts_mat_def
by (metis P carrier_matD(1) carrier_matD(2) carrier_matI index_mult_mat(3) index_one_mat(3))
have Q': "Q' ∈ carrier_mat n n"
using QQ' Q'Q unfolding inverts_mat_def
by (metis Q carrier_matD(1) carrier_matD(2) carrier_matI index_mult_mat(3) index_one_mat(3))
have rw: "P' *?B *Q' = A"
proof -
have f1: "P' * P = 1⇩m m"
by (metis (no_types) P' P'P carrier_matD(1) inverts_mat_def)
have *: "P' * P * A = P' * (P * A)"
by (meson A P P' assoc_mult_mat)
have " P' * (P * A * Q) * Q' = P' * P * A * Q * Q'"
by (smt A P P' Q assoc_mult_mat mult_carrier_mat)
also have "... = P' * P * (A * Q * Q')"
using A P P' Q Q' f1 * by auto
also have "... = A * Q * Q'" using P'P A P' unfolding inverts_mat_def by auto
also have "... = A" using QQ' A Q' Q unfolding inverts_mat_def by auto
finally show ?thesis .
qed
have "Gcd (minors ?B k) dvd det (submatrix (P'*?B*Q') I J)"
by (rule Gcd_minors_dvd[OF _ P' _ Q' _ _ Ik Jk], insert P A Q I J, auto)
also have "... = det (submatrix A I J)" using rw by simp
finally show "Gcd (minors ?B k) dvd b" using b by simp
qed
lemma Gcd_minors_dvd_diag_PAQ:
fixes P A Q::"'a::{semiring_Gcd,comm_ring_1} mat"
assumes A: "A ∈ carrier_mat m n"
and P: "P ∈ carrier_mat m m"
and Q: "Q ∈ carrier_mat n n"
and SNF: "Smith_normal_form_mat (P*A*Q)"
and k: "k≤min m n"
shows "Gcd (minors A k) dvd (∏i=0..<k. (P * A * Q) $$ (i,i))"
proof -
have "Gcd (minors A k) dvd Gcd (minors (P * A * Q) k)"
by (rule Gcd_minors_A_dvd_Gcd_minors_PAQ[OF A P Q])
also have "... dvd (∏i=0..<k. (P*A*Q) $$ (i,i))"
by (rule Gcd_minors_dvd_diagonal[OF _ SNF k], insert P A Q, auto)
finally show ?thesis .
qed
lemma diag_PAQ_dvd_Gcd_minors:
fixes P A Q::"'a::{semiring_Gcd,comm_ring_1} mat"
assumes A: "A ∈ carrier_mat m n"
and P: "P ∈ carrier_mat m m"
and Q: "Q ∈ carrier_mat n n"
and inv_P: "invertible_mat P"
and inv_Q: "invertible_mat Q"
and SNF: "Smith_normal_form_mat (P*A*Q)"
shows "(∏i=0..<k. (P * A * Q) $$ (i,i)) dvd Gcd (minors A k)"
proof -
have "(∏i=0..<k. (P*A*Q) $$ (i,i)) dvd Gcd (minors (P * A * Q) k)"
by (rule diagonal_dvd_Gcd_minors[OF _ SNF], auto)
also have "... dvd Gcd (minors A k)"
by (rule Gcd_minors_PAQ_dvd_Gcd_minors_A[OF _ _ _ inv_P inv_Q], insert P A Q, auto)
finally show ?thesis .
qed
lemma Smith_prod_zero_imp_last_zero:
fixes A::"'a::{semidom,comm_ring_1} mat"
assumes A: "A ∈ carrier_mat m n"
and SNF: "Smith_normal_form_mat A"
and prod_0: "(∏j=0..<Suc i. A $$ (j,j)) = 0"
and i: "i<min m n"
shows "A $$(i,i) = 0"
proof -
obtain j where Ajj: "A$$(j,j) = 0" and j: "j<Suc i" using prod_0 prod_zero_iff by auto
show "A $$(i,i) = 0" by (rule Smith_zero_imp_zero[OF A SNF Ajj i], insert j, auto)
qed
subsection ‹Final theorem›
lemma Smith_normal_form_uniqueness_aux:
fixes P A Q::"'a::{idom,semiring_Gcd} mat"
assumes A: "A ∈ carrier_mat m n"
and P: "P ∈ carrier_mat m m"
and Q: "Q ∈ carrier_mat n n"
and inv_P: "invertible_mat P"
and inv_Q: "invertible_mat Q"
and PAQ_B: "P*A*Q = B"
and SNF: "Smith_normal_form_mat B"
and P': "P' ∈ carrier_mat m m"
and Q': "Q' ∈ carrier_mat n n"
and inv_P': "invertible_mat P'"
and inv_Q': "invertible_mat Q'"
and P'AQ'_B': "P'*A*Q' = B'"
and SNF_B': "Smith_normal_form_mat B'"
and k: "k<min m n"
shows "∀i≤k. B$$(i,i) dvd B'$$(i,i) ∧ B'$$(i,i) dvd B$$(i,i)"
proof (rule allI, rule impI)
fix i assume ik: "i ≤ k"
show " B $$ (i, i) dvd B' $$ (i, i) ∧ B' $$ (i, i) dvd B $$ (i, i)"
proof -
let ?ΠBi = "(∏i=0..<i. B $$ (i,i))"
let ?ΠB'i = "(∏i=0..<i. B' $$ (i,i))"
have "?ΠB'i dvd Gcd (minors A i)"
by (unfold P'AQ'_B'[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P' Q' inv_P' inv_Q'],
insert P'AQ'_B' SNF_B' ik k, auto )
also have "... dvd ?ΠBi"
by (unfold PAQ_B[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P Q],
insert PAQ_B SNF ik k, auto)
finally have B'_i_dvd_B_i: "?ΠB'i dvd ?ΠBi" .
have "?ΠBi dvd Gcd (minors A i)"
by (unfold PAQ_B[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P Q inv_P inv_Q],
insert PAQ_B SNF ik k, auto )
also have "... dvd ?ΠB'i"
by (unfold P'AQ'_B'[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P' Q'],
insert P'AQ'_B' SNF_B' ik k, auto)
finally have B_i_dvd_B'_i: "?ΠBi dvd ?ΠB'i" .
let ?ΠB_Suc = "(∏i=0..<Suc i. B $$ (i,i))"
let ?ΠB'_Suc = "(∏i=0..<Suc i. B' $$ (i,i))"
have "?ΠB'_Suc dvd Gcd (minors A (Suc i))"
by (unfold P'AQ'_B'[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P' Q' inv_P' inv_Q'],
insert P'AQ'_B' SNF_B' ik k, auto )
also have "... dvd ?ΠB_Suc"
by (unfold PAQ_B[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P Q],
insert PAQ_B SNF ik k, auto)
finally have 3: "?ΠB'_Suc dvd ?ΠB_Suc" .
have "?ΠB_Suc dvd Gcd (minors A (Suc i))"
by (unfold PAQ_B[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P Q inv_P inv_Q],
insert PAQ_B SNF ik k, auto )
also have "... dvd ?ΠB'_Suc"
by (unfold P'AQ'_B'[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P' Q'],
insert P'AQ'_B' SNF_B' ik k, auto)
finally have 4: "?ΠB_Suc dvd ?ΠB'_Suc" .
show ?thesis
proof (cases "?ΠB_Suc = 0")
case True
have True2: "?ΠB'_Suc = 0" using 4 True by fastforce
have "B$$(i,i) = 0"
by (rule Smith_prod_zero_imp_last_zero[OF _ SNF True], insert ik k PAQ_B P Q, auto)
moreover have "B'$$(i,i) = 0"
by (rule Smith_prod_zero_imp_last_zero[OF _ SNF_B' True2],
insert ik k P'AQ'_B' P' Q', auto)
ultimately show ?thesis by auto
next
case False
have "∃u. u dvd 1 ∧ ?ΠB'i = u * ?ΠBi"
by (rule dvd_associated2[OF B'_i_dvd_B_i B_i_dvd_B'_i], insert False B'_i_dvd_B_i, force)
from this obtain u where eq1: "(∏i=0..<i. B' $$ (i,i)) = u * (∏i=0..<i. B $$ (i,i))"
and u_dvd_1: "u dvd 1" by blast
have "∃u. u dvd 1 ∧ ?ΠB_Suc = u * ?ΠB'_Suc"
by (rule dvd_associated2[OF 4 3 False])
from this obtain w where eq2: "(∏i=0..<Suc i. B $$ (i,i)) = w * (∏i=0..<Suc i. B' $$ (i,i))"
and w_dvd_1: "w dvd 1" by blast
have "B $$ (i, i) * (∏i=0..<i. B $$ (i,i)) = (∏i=0..<Suc i. B $$ (i,i))"
by (simp add: prod.atLeast0_lessThan_Suc ik)
also have "... = w * (∏i=0..<Suc i. B' $$ (i,i))" unfolding eq2 by auto
also have "... = w * (B' $$ (i,i) * (∏i=0..<i. B' $$ (i,i)))"
by (simp add: prod.atLeast0_lessThan_Suc ik)
also have "... = w * (B' $$ (i,i) * u * (∏i=0..<i. B $$ (i,i)))"
unfolding eq1 by auto
finally have "B $$ (i,i) = w * u * B' $$ (i,i)"
using False by auto
moreover have "w*u dvd 1" using u_dvd_1 w_dvd_1 by auto
ultimately have "∃u. is_unit u ∧ B $$ (i, i) = u * B' $$ (i, i)" by auto
thus ?thesis using dvd_associated2 by force
qed
qed
qed
lemma Smith_normal_form_uniqueness:
fixes P A Q::"'a::{idom,semiring_Gcd} mat"
assumes A: "A ∈ carrier_mat m n"
and P: "P ∈ carrier_mat m m"
and Q: "Q ∈ carrier_mat n n"
and inv_P: "invertible_mat P"
and inv_Q: "invertible_mat Q"
and PAQ_B: "P*A*Q = B"
and SNF: "Smith_normal_form_mat B"
and P': "P' ∈ carrier_mat m m"
and Q': "Q' ∈ carrier_mat n n"
and inv_P': "invertible_mat P'"
and inv_Q': "invertible_mat Q'"
and P'AQ'_B': "P'*A*Q' = B'"
and SNF_B': "Smith_normal_form_mat B'"
and i: "i < min m n"
shows "∃u. u dvd 1 ∧ B $$ (i,i) = u * B' $$ (i,i)"
proof (cases "B $$ (i,i) = 0")
case True
let ?ΠB_Suc = "(∏i=0..<Suc i. B $$ (i,i))"
let ?ΠB'_Suc = "(∏i=0..<Suc i. B' $$ (i,i))"
have "?ΠB_Suc dvd Gcd (minors A (Suc i))"
by (unfold PAQ_B[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P Q inv_P inv_Q],
insert PAQ_B SNF i, auto)
also have "... dvd ?ΠB'_Suc"
by (unfold P'AQ'_B'[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P' Q'],
insert P'AQ'_B' SNF_B' i, auto)
finally have 4: "?ΠB_Suc dvd ?ΠB'_Suc" .
have prod0: "?ΠB_Suc=0" using True by auto
have True2: "?ΠB'_Suc = 0" using 4 by (metis dvd_0_left_iff prod0)
have "B'$$(i,i) = 0"
by (rule Smith_prod_zero_imp_last_zero[OF _ SNF_B' True2],
insert i P'AQ'_B' P' Q', auto)
thus ?thesis using True by auto
next
case False
have "∀a≤i. B$$(a,a) dvd B'$$(a,a) ∧ B'$$(a,a) dvd B$$(a,a)"
by (rule Smith_normal_form_uniqueness_aux[OF assms])
hence "B$$(i,i) dvd B'$$(i,i) ∧ B'$$(i,i) dvd B$$(i,i)" using i by auto
thus ?thesis using dvd_associated2 False by blast
qed
text ‹The final theorem, moved to HOL Analysis›
lemma Smith_normal_form_uniqueness_HOL_Analysis:
fixes A::"'a::{idom,semiring_Gcd}^'m::mod_type^'n::mod_type"
and P P'::"'a^'n::mod_type^'n::mod_type"
and Q Q'::"'a^'m::mod_type^'m::mod_type"
assumes
inv_P: "invertible P"
and inv_Q: "invertible Q"
and PAQ_B: "P**A**Q = B"
and SNF: "Smith_normal_form B"
and inv_P': "invertible P'"
and inv_Q': "invertible Q'"
and P'AQ'_B': "P'**A**Q' = B'"
and SNF_B': "Smith_normal_form B'"
and i: "i < min (nrows A) (ncols A)"
shows "∃u. u dvd 1 ∧ B $h Mod_Type.from_nat i $h Mod_Type.from_nat i
= u * B' $h Mod_Type.from_nat i $h Mod_Type.from_nat i"
proof -
let ?P = "Mod_Type_Connect.from_hma⇩m P"
let ?A = "Mod_Type_Connect.from_hma⇩m A"
let ?Q = "Mod_Type_Connect.from_hma⇩m Q"
let ?B = "Mod_Type_Connect.from_hma⇩m B"
let ?P' = "Mod_Type_Connect.from_hma⇩m P'"
let ?Q' = "Mod_Type_Connect.from_hma⇩m Q'"
let ?B' = "Mod_Type_Connect.from_hma⇩m B'"
let ?i = "(Mod_Type.from_nat i)::'n"
let ?i' = "(Mod_Type.from_nat i)::'m"
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?P P" by (simp add: Mod_Type_Connect.HMA_M_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A" by (simp add: Mod_Type_Connect.HMA_M_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q Q" by (simp add: Mod_Type_Connect.HMA_M_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B B" by (simp add: Mod_Type_Connect.HMA_M_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?P' P'" by (simp add: Mod_Type_Connect.HMA_M_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q' Q'" by (simp add: Mod_Type_Connect.HMA_M_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B' B'" by (simp add: Mod_Type_Connect.HMA_M_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i"
by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE
mod_type_class.to_nat_from_nat_id nrows_def)
have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'"
by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE
mod_type_class.to_nat_from_nat_id ncols_def)
have i2: "i < min CARD('m) CARD('n)" using i unfolding nrows_def ncols_def by auto
have "∃u. u dvd 1 ∧ ?B $$(i,i) = u * ?B' $$ (i,i)"
proof (rule Smith_normal_form_uniqueness[of _ "CARD('n)" "CARD('m)"])
show "?P*?A*?Q=?B" using PAQ_B by (transfer', auto)
show "Smith_normal_form_mat ?B" using SNF by (transfer', auto)
show "?P'*?A*?Q'=?B'" using P'AQ'_B' by (transfer', auto)
show "Smith_normal_form_mat ?B'" using SNF_B' by (transfer', auto)
show "invertible_mat ?P" using inv_P by (transfer, auto)
show "invertible_mat ?P'" using inv_P' by (transfer, auto)
show "invertible_mat ?Q" using inv_Q by (transfer, auto)
show "invertible_mat ?Q'" using inv_Q' by (transfer, auto)
qed (insert i2, auto)
hence "∃u. u dvd 1 ∧ (index_hma B ?i ?i') = u * (index_hma B' ?i ?i')" by (transfer', rule)
thus ?thesis unfolding index_hma_def by simp
qed
subsection ‹Uniqueness fixing a complete set of non-associates›
definition "Smith_normal_form_wrt A 𝒬 = (
(∀a b. Mod_Type.to_nat a = Mod_Type.to_nat b ∧ Mod_Type.to_nat a + 1 < nrows A
∧ Mod_Type.to_nat b + 1 < ncols A ⟶ A $h a $h b dvd A $h (a+1) $h (b+1))
∧ isDiagonal A ∧ Complete_set_non_associates 𝒬
∧ (∀a b. Mod_Type.to_nat a = Mod_Type.to_nat b ∧ Mod_Type.to_nat a < min (nrows A) (ncols A)
∧ Mod_Type.to_nat b < min (nrows A) (ncols A) ⟶ A $h a $h b ∈ 𝒬)
)"
lemma Smith_normal_form_wrt_uniqueness_HOL_Analysis:
fixes A::"'a::{idom,semiring_Gcd}^'m::mod_type^'n::mod_type"
and P P'::"'a^'n::mod_type^'n::mod_type"
and Q Q'::"'a^'m::mod_type^'m::mod_type"
assumes
P: "invertible P"
and Q: "invertible Q"
and PAQ_S: "P**A**Q = S"
and SNF: "Smith_normal_form_wrt S 𝒬"
and P': "invertible P'"
and Q': "invertible Q'"
and P'AQ'_S': "P'**A**Q' = S'"
and SNF_S': "Smith_normal_form_wrt S' 𝒬"
shows "S = S'"
proof -
have "S $h i $h j = S' $h i $h j" for i j
proof (cases "Mod_Type.to_nat i ≠ Mod_Type.to_nat j")
case True
then show ?thesis using SNF SNF_S' unfolding Smith_normal_form_wrt_def isDiagonal_def by auto
next
case False
let ?i = "Mod_Type.to_nat i"
let ?j = "Mod_Type.to_nat j"
have complete_set: "Complete_set_non_associates 𝒬"
using SNF_S' unfolding Smith_normal_form_wrt_def by simp
have ij: "?i = ?j" using False by auto
show ?thesis
proof (rule ccontr)
assume d: "S $h i $h j ≠ S' $h i $h j"
have n: "normalize (S $h i $h j) ≠ normalize (S' $h i $h j)"
proof (rule in_Ass_not_associated[OF complete_set _ _ d])
show "S $h i $h j ∈ 𝒬" using SNF unfolding Smith_normal_form_wrt_def
by (metis False min_less_iff_conj mod_type_class.to_nat_less_card ncols_def nrows_def)
show "S' $h i $h j ∈ 𝒬" using SNF_S' unfolding Smith_normal_form_wrt_def
by (metis False min_less_iff_conj mod_type_class.to_nat_less_card ncols_def nrows_def)
qed
have "∃u. u dvd 1 ∧ S $h i $h j = u * S' $h i $h j"
proof -
have "∃u. u dvd 1 ∧ S $h Mod_Type.from_nat ?i $h Mod_Type.from_nat ?i
= u * S' $h Mod_Type.from_nat ?i $h Mod_Type.from_nat ?i"
proof (rule Smith_normal_form_uniqueness_HOL_Analysis[OF P Q PAQ_S _ P' Q' P'AQ'_S' _])
show "Smith_normal_form S" and "Smith_normal_form S'"
using SNF SNF_S' Smith_normal_form_def Smith_normal_form_wrt_def by blast+
show "?i < min (nrows A) (ncols A)"
by (metis ij min_less_iff_conj mod_type_class.to_nat_less_card ncols_def nrows_def)
qed
thus ?thesis using False by auto
qed
from this obtain u where "is_unit u" and "S $h i $h j = u * S' $h i $h j" by auto
thus False using n
by (simp add: normalize_1_iff normalize_mult)
qed
qed
thus ?thesis by vector
qed
end
Theory Cauchy_Binet_HOL_Analysis
section ‹The Cauchy--Binet formula in HOL Analysis›
theory Cauchy_Binet_HOL_Analysis
imports
Cauchy_Binet
Perron_Frobenius.HMA_Connect
begin
subsection ‹Definition of submatrices in HOL Analysis›
definition submatrix_hma :: "'a^'nc^'nr⇒nat set⇒nat set⇒('a^'nc2^'nr2)"
where "submatrix_hma A I J = (χ a b. A $h (from_nat (pick I (to_nat a))) $h (from_nat (pick J (to_nat b))))"
context includes lifting_syntax
begin
context
fixes I::"nat set" and J::"nat set"
assumes I: "card {i. i < CARD('nr::finite) ∧ i ∈ I} = CARD('nr2::finite)"
assumes J: "card {i. i < CARD('nc::finite) ∧ i ∈ J} = CARD('nc2::finite)"
begin
lemma HMA_submatrix[transfer_rule]: "(HMA_M ===> HMA_M) (λA. submatrix A I J)
((λA. submatrix_hma A I J):: 'a^ 'nc ^ 'nr ⇒ 'a ^ 'nc2 ^ 'nr2)"
proof (intro rel_funI, goal_cases)
case (1 A B)
note relAB[transfer_rule] = this
show ?case unfolding HMA_M_def
proof (rule eq_matI, auto)
show "dim_row (submatrix A I J) = CARD('nr2)"
unfolding submatrix_def
using I dim_row_transfer_rule relAB by force
show "dim_col (submatrix A I J) = CARD('nc2)"
unfolding submatrix_def
using J dim_col_transfer_rule relAB by force
let ?B="(submatrix_hma B I J)::'a ^ 'nc2 ^ 'nr2"
fix i j assume i: "i < CARD('nr2)" and
j: "j < CARD('nc2)"
have i2: "i < card {i. i < dim_row A ∧ i ∈ I}"
using I dim_row_transfer_rule i relAB by fastforce
have j2: "j < card {j. j < dim_col A ∧ j ∈ J}"
using J dim_col_transfer_rule j relAB by fastforce
let ?i = "(from_nat (pick I i))::'nr"
let ?j = "(from_nat (pick J j))::'nc"
let ?i' = "Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2)"
let ?j' = "Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2)"
have i': "?i' = i" by (rule to_nat_from_nat_id[OF i])
have j': "?j' = j" by (rule to_nat_from_nat_id[OF j])
let ?f = "(λ(i, j).
B $h Bij_Nat.from_nat (pick I (Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2))) $h
Bij_Nat.from_nat (pick J (Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2))))"
have [transfer_rule]: "HMA_I (pick I i) ?i"
by (simp add: Bij_Nat.to_nat_from_nat_id I i pick_le HMA_I_def)
have [transfer_rule]: "HMA_I (pick J j) ?j"
by (simp add: Bij_Nat.to_nat_from_nat_id J j pick_le HMA_I_def)
have "submatrix A I J $$ (i, j) = A $$ (pick I i, pick J j)" by (rule submatrix_index[OF i2 j2])
also have "... = index_hma B ?i ?j" by (transfer, simp)
also have "... = B $h Bij_Nat.from_nat (pick I (Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2))) $h
Bij_Nat.from_nat (pick J (Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2)))"
unfolding i' j' index_hma_def by auto
also have "... = ?f (i,j)" by auto
also have "... = Matrix.mat CARD('nr2) CARD('nc2) ?f $$ (i, j)"
by (rule index_mat[symmetric, OF i j])
also have "... = from_hma⇩m ?B $$ (i, j)"
unfolding from_hma⇩m_def submatrix_hma_def by auto
finally show "submatrix A I J $$ (i, j) = from_hma⇩m ?B $$ (i, j)" .
qed
qed
end
end
subsection ‹Transferring the proof from JNF to HOL Analysis›
lemma Cauchy_Binet_HOL_Analysis:
fixes A::"'a::comm_ring_1^'m^'n" and B::"'a^'n^'m"
shows "Determinants.det (A**B) = (∑I∈{I. I⊆{0..<ncols A} ∧ card I=nrows A}.
Determinants.det ((submatrix_hma A UNIV I)::'a^'n^'n) *
Determinants.det ((submatrix_hma B I UNIV)::'a^'n^'n))"
proof -
let ?A = "(from_hma⇩m A)"
let ?B = "(from_hma⇩m B)"
have relA[transfer_rule]: "HMA_M ?A A" unfolding HMA_M_def by simp
have relB[transfer_rule]: "HMA_M ?B B" unfolding HMA_M_def by simp
have "(∑I∈{I. I⊆{0..<ncols A} ∧ card I = nrows A}.
Determinants.det ((submatrix_hma A UNIV I)::'a^'n^'n) *
Determinants.det ((submatrix_hma B I UNIV)::'a^'n^'n)) =
(∑I∈{I. I⊆{0..<ncols A} ∧ card I=nrows A}. det (submatrix ?A UNIV I)
* det (submatrix ?B I UNIV))"
proof (rule sum.cong)
fix I assume I: "I ∈{I. I⊆{0..<ncols A} ∧ card I=nrows A}"
let ?sub_A= "((submatrix_hma A UNIV I)::'a^'n^'n)"
let ?sub_B= "((submatrix_hma B I UNIV)::'a^'n^'n)"
have c1: "card {i. i < CARD('n) ∧ i ∈ UNIV} = CARD('n)" using I by auto
have c2: "card {i. i < CARD('m) ∧ i ∈ I} = CARD('n)"
proof -
have "I = {i. i < CARD('m) ∧ i ∈ I}" using I unfolding nrows_def ncols_def by auto
thus ?thesis using I nrows_def by auto
qed
have [transfer_rule]: "HMA_M (submatrix ?A UNIV I) ?sub_A"
using HMA_submatrix[OF c1 c2] relA unfolding rel_fun_def by auto
have [transfer_rule]: "HMA_M (submatrix ?B I UNIV) ?sub_B"
using HMA_submatrix[OF c2 c1] relB unfolding rel_fun_def by auto
show "Determinants.det ?sub_A * Determinants.det ?sub_B
= det (submatrix ?A UNIV I) * det (submatrix ?B I UNIV)" by (transfer', auto)
qed (auto)
also have "... = det (?A*?B)"
by (rule Cauchy_Binet[symmetric], unfold nrows_def ncols_def, auto)
also have "... = Determinants.det (A**B)" by (transfer', auto)
finally show ?thesis ..
qed
end
Theory Diagonalize
section ‹Diagonalizing matrices in JNF and HOL Analysis›
theory Diagonalize
imports Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin
text ‹This section presents a @{text "locale"} that assumes a sound operation to make a matrix
diagonal. Then, the result is transferred to HOL Analysis.›
subsection ‹Diagonalizing matrices in JNF›
text ‹We assume a @{text "diagonalize_JNF"} operation in JNF, which is applied to matrices over
a B\'ezout ring. However, probably a more restrictive type class is required.›
locale diagonalize =
fixes diagonalize_JNF :: "'a::bezout_ring mat ⇒ 'a bezout ⇒ ('a mat × 'a mat × 'a mat)"
assumes soundness_diagonalize_JNF:
"∀A bezout. A ∈ carrier_mat m n ∧ is_bezout_ext bezout ⟶
(case diagonalize_JNF A bezout of (P,S,Q) ⇒
P ∈ carrier_mat m m ∧ Q ∈ carrier_mat n n ∧ S ∈ carrier_mat m n
∧ invertible_mat P ∧ invertible_mat Q ∧ isDiagonal_mat S ∧ S = P*A*Q)"
begin
lemma soundness_diagonalize_JNF':
fixes A::"'a mat"
assumes "is_bezout_ext bezout" and "A ∈ carrier_mat m n"
and "diagonalize_JNF A bezout = (P,S,Q)"
shows "P ∈ carrier_mat m m ∧ Q ∈ carrier_mat n n ∧ S ∈ carrier_mat m n
∧ invertible_mat P ∧ invertible_mat Q ∧ isDiagonal_mat S ∧ S = P*A*Q"
using soundness_diagonalize_JNF assms unfolding case_prod_beta by (metis fst_conv snd_conv)
subsection ‹Implementation and soundness result moved to HOL Analysis.›
definition diagonalize :: "'a::bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type
⇒ 'a bezout ⇒
(('a ^ 'nr :: mod_type ^ 'nr :: mod_type)
× ('a ^ 'nc :: mod_type ^ 'nr :: mod_type)
× ('a ^ 'nc :: mod_type ^ 'nc :: mod_type))"
where "diagonalize A bezout = (
let (P,S,Q) = diagonalize_JNF (Mod_Type_Connect.from_hma⇩m A) bezout
in (Mod_Type_Connect.to_hma⇩m P,Mod_Type_Connect.to_hma⇩m S,Mod_Type_Connect.to_hma⇩m Q)
)"
lemma soundness_diagonalize:
assumes b: "is_bezout_ext bezout"
and d: "diagonalize A bezout = (P,S,Q)"
shows "invertible P ∧ invertible Q ∧ isDiagonal S ∧ S = P**A**Q"
proof -
define A' where "A' = Mod_Type_Connect.from_hma⇩m A"
obtain P' S' Q' where d_JNF: "(P',S',Q') = diagonalize_JNF A' bezout"
by (metis prod_cases3)
define m and n where "m = dim_row A'" and "n = dim_col A'"
hence A': "A' ∈ carrier_mat m n" by auto
have res_JNF: "P' ∈ carrier_mat m m ∧ Q' ∈ carrier_mat n n ∧ S' ∈ carrier_mat m n
∧ invertible_mat P' ∧ invertible_mat Q' ∧ isDiagonal_mat S' ∧ S' = P'*A'*Q'"
by (rule soundness_diagonalize_JNF'[OF b A' d_JNF[symmetric]])
have "Mod_Type_Connect.to_hma⇩m P' = P" using d unfolding diagonalize_def Let_def
by (metis A'_def d_JNF fst_conv old.prod.case)
hence "P' = Mod_Type_Connect.from_hma⇩m P" using A'_def m_def res_JNF by auto
hence [transfer_rule]: "Mod_Type_Connect.HMA_M P' P"
unfolding Mod_Type_Connect.HMA_M_def by auto
have "Mod_Type_Connect.to_hma⇩m Q' = Q" using d unfolding diagonalize_def Let_def
by (metis A'_def d_JNF snd_conv old.prod.case)
hence "Q' = Mod_Type_Connect.from_hma⇩m Q" using A'_def n_def res_JNF by auto
hence [transfer_rule]: "Mod_Type_Connect.HMA_M Q' Q"
unfolding Mod_Type_Connect.HMA_M_def by auto
have "Mod_Type_Connect.to_hma⇩m S' = S" using d unfolding diagonalize_def Let_def
by (metis A'_def d_JNF snd_conv old.prod.case)
hence "S' = Mod_Type_Connect.from_hma⇩m S" using A'_def m_def n_def res_JNF by auto
hence [transfer_rule]: "Mod_Type_Connect.HMA_M S' S"
unfolding Mod_Type_Connect.HMA_M_def by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_M A' A"
using A'_def unfolding Mod_Type_Connect.HMA_M_def by auto
have "invertible P" using res_JNF by (transfer, simp)
moreover have "invertible Q" using res_JNF by (transfer, simp)
moreover have "isDiagonal S" using res_JNF by (transfer, simp)
moreover have "S = P**A**Q" using res_JNF by (transfer, simp)
ultimately show ?thesis by simp
qed
end
end
Theory SNF_Algorithm_Two_Steps
section ‹Smith normal form algorithm based on two steps in HOL Analysis›
theory SNF_Algorithm_Two_Steps
imports Diagonalize
begin
text ‹This file contains an algorithm to transform a matrix to its Smith normal form, based
on two steps: first it is converted into a diagonal matrix and then transformed from diagonal
to Smith.
We assume the existence of a diagonalize operation, and then we just have to connect it to the
existing algorithm (in HOL Analysis) to transform a diagonal matrix into its Smith normal form.
›
subsection ‹The implementation›
context diagonalize
begin
definition "Smith_normal_form_of A bezout = (
let (P'',D,Q'') = diagonalize A bezout;
(P',S,Q') = diagonal_to_Smith_PQ D bezout
in (P'**P'',S,Q''**Q')
)"
subsection ‹Soundness in HOL Analysis›
lemma Smith_normal_form_of_soundness:
fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
assumes b: "is_bezout_ext bezout"
assumes PSQ: "(P,S,Q) = Smith_normal_form_of A bezout"
shows "S = P**A**Q ∧ invertible P ∧ invertible Q ∧ Smith_normal_form S"
proof -
obtain P'' D Q'' where PDQ_diag: "(P'',D,Q'') = diagonalize A bezout"
by (metis prod_cases3)
have 1: "invertible P'' ∧ invertible Q'' ∧ isDiagonal D ∧ D = P''**A**Q''"
by (rule soundness_diagonalize[OF b PDQ_diag[symmetric]])
obtain P' Q' where PSQ_D: "(P',S,Q') = diagonal_to_Smith_PQ D bezout"
using PSQ PDQ_diag unfolding Smith_normal_form_of_def
unfolding Let_def by (smt Pair_inject case_prod_beta' surjective_pairing)
have 2: "invertible P' ∧ invertible Q' ∧ Smith_normal_form S ∧ S = P'**D**Q'"
using diagonal_to_Smith_PQ' 1 b PSQ_D by blast
have P: "P = P'**P''"
by (metis (mono_tags, lifting) PDQ_diag PSQ_D Pair_inject
Smith_normal_form_of_def PSQ old.prod.case)
have Q: "Q = Q''**Q'"
by (metis (mono_tags, lifting) PDQ_diag PSQ_D Pair_inject
Smith_normal_form_of_def PSQ old.prod.case)
have "S = P**A**Q" using 1 2 by (simp add: P Q matrix_mul_assoc)
moreover have "invertible P" using P by (simp add: 1 2 invertible_mult)
moreover have "invertible Q" using Q by (simp add: 1 2 invertible_mult)
ultimately show ?thesis using 2 by auto
qed
end
end
Theory Diagonal_To_Smith_JNF
section ‹Algorithm to transform a diagonal matrix into its Smith normal form in JNF›
theory Diagonal_To_Smith_JNF
imports Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin
text ‹In this file, we implement an algorithm to transform a diagonal matrix into its Smith
normal form, using the JNF library.
There are, at least, three possible options:
\begin{enumerate}
\item Implement and prove the soundness of the algorithm from scratch in JNF
\item Implement it in JNF and connect it to the HOL Analysis version by means of transfer rules.
Thus, we could obtain the soundness lemma in JNF.
\item Implement it in JNF, with calls to the HOL Analysis version by means of the functions
@{text " from_hma⇩m"} and @{text "to_hma⇩m"}. That is, transform the matrix to HOL Analysis, apply
the existing algorith in HOL Analysis to get the Smith normal form and then transform the output
to JNF. Then, we could try to get the soundness theorem in JNF by means of
transfer rules and local type definitions.
\end{enumerate}
The first option requires much effort. As we will see, the third option is not possible.
›
subsection ‹Attempt with the third option: definitions and conditional transfer rules›
context
fixes A::"'a::bezout_ring mat"
assumes "A ∈ carrier_mat CARD('nr::mod_type) CARD('nc::mod_type)"
begin
private definition "diagonal_to_Smith_PQ_JNF' bezout = (
let A' = Mod_Type_Connect.to_hma⇩m A::'a^'nc::mod_type^'nr::mod_type;
(P,S,Q) = (diagonal_to_Smith_PQ A' bezout)
in (Mod_Type_Connect.from_hma⇩m P, Mod_Type_Connect.from_hma⇩m S, Mod_Type_Connect.from_hma⇩m Q))"
end
text ‹This approach will not work. The type is necessary in the definition of the function.
That is, outside the context, the function will be:
@{text "diagonal_to_Smith_PQ_JNF' TYPE('nc) TYPE('nr) A bezout"}
And we cannot get rid of such @{text "TYPE('nc)"}.
That is, we could get a lemma like:
@{theory_text "
lemma
assumes A ∈ carrier_mat m n
and (P,S,Q) = diagonal_to_Smith_PQ_JNF' TYPE('nr::mod_type) TYPE('nc::mod_type) A bezout
shows invertible_mat P ∧ invertible_mat Q ∧ S = P * A * Q ∧ Smith_normal_form_mat S
"}
But we wouldn't be able to get rid of such types.
›
subsection ‹Attempt with the second option: implementation and soundness in JNF›
definition "diagonal_step_JNF A i j d v =
Matrix.mat (dim_row A) (dim_col A) (λ (a,b). if a = i ∧ b = i then d else
if a = j ∧ b = j
then v * (A $$ (j,j)) else A $$ (a,b))"
text ‹Conditional transfer rules are required, so I prove them within context with assumptions.›
context
includes lifting_syntax
fixes i and j::nat
assumes i: "i<min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
and j: "j<min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin
lemma HMA_diagonal_step[transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ _)
===> (=) ===> (=) ===> Mod_Type_Connect.HMA_M)
(λA. diagonal_step_JNF A i j) (λB. diagonal_step B i j)"
by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def
diagonal_step_JNF_def diagonal_step_def)
(rule eq_matI, auto simp add: Mod_Type_Connect.from_hma⇩m_def, insert from_nat_eq_imp_eq i j, auto)
end
definition diagonal_step_PQ_JNF ::
"'a::{bezout_ring} mat ⇒ nat ⇒ nat ⇒ 'a bezout ⇒ ('a mat × ('a mat))"
where "diagonal_step_PQ_JNF A i k bezout =
(let m = dim_row A; n = dim_col A;
(p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (k,k));
P = addrow (-v) k i (swaprows i k (addrow p k i (1⇩m m)));
Q = multcol k (-1) (addcol u k i (addcol q i k (1⇩m n)))
in (P,Q)
)"
context
includes lifting_syntax
fixes i and k::nat
assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
and k: "k < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin
lemma HMA_diagonal_step_PQ[transfer_rule]:
"((Mod_Type_Connect.HMA_M :: _ ⇒ 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type ⇒ _)
===> (=) ===> rel_prod Mod_Type_Connect.HMA_M Mod_Type_Connect.HMA_M)
(λA bezout. diagonal_step_PQ_JNF A i k bezout) (λA bezout. diagonal_step_PQ A i k bezout)"
proof (intro rel_funI, goal_cases)
case (1 A A' bezout bezout')
note HMA_M_AA'[transfer_rule] = 1(1)
let ?d_JNF = "(diagonal_step_PQ_JNF A i k bezout)"
let ?d_HA = "(diagonal_step_PQ A' i k bezout)"
have [transfer_rule]: "Mod_Type_Connect.HMA_I k (from_nat k::'nc)"
and [transfer_rule]: "Mod_Type_Connect.HMA_I k (from_nat k::'nr)"
by (metis Mod_Type_Connect.HMA_I_def k min.strict_boundedE to_nat_from_nat_id)+
have [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nc)"
and [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nr)"
by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE to_nat_from_nat_id)+
have [transfer_rule]: "A $$ (i,i) = A' $h from_nat i $h from_nat i"
proof -
have "A $$ (i,i) = index_hma A' (from_nat i) (from_nat i)" by (transfer, simp)
also have "... = A' $h from_nat i $h from_nat i" unfolding index_hma_def by auto
finally show ?thesis .
qed
have [transfer_rule]: "A $$ (k,k) = A' $h from_nat k $h from_nat k"
proof -
have "A $$ (k,k) = index_hma A' (from_nat k) (from_nat k)" by (transfer, simp)
also have "... = A' $h from_nat k $h from_nat k" unfolding index_hma_def by auto
finally show ?thesis .
qed
have dim_row_CARD: "dim_row A = CARD('nr)"
using HMA_M_AA' Mod_Type_Connect.dim_row_transfer_rule by blast
have dim_col_CARD: "dim_col A = CARD('nc)"
using HMA_M_AA' Mod_Type_Connect.dim_col_transfer_rule by blast
let ?p = "fst (bezout (A' $h from_nat i $h from_nat i) (A' $h from_nat k $h from_nat k))"
let ?v = "fst (snd (snd (snd (bezout (A $$ (i, i)) (A $$ (k, k))))))"
have "Mod_Type_Connect.HMA_M (fst ?d_JNF) (fst ?d_HA)"
unfolding diagonal_step_PQ_JNF_def diagonal_step_PQ_def Mod_Type_Connect.HMA_M_def
unfolding Let_def split_beta dim_row_CARD
by (auto, transfer, auto simp add: Mod_Type_Connect.HMA_M_def Rel_def rel_funI)
moreover have "Mod_Type_Connect.HMA_M (snd ?d_JNF) (snd ?d_HA)"
unfolding diagonal_step_PQ_JNF_def diagonal_step_PQ_def Mod_Type_Connect.HMA_M_def
unfolding Let_def split_beta dim_col_CARD
by (auto, transfer, auto simp add: Mod_Type_Connect.HMA_M_def Rel_def rel_funI)
ultimately show ?case unfolding rel_prod_conv using 1
by (simp add: split_beta)
qed
end
fun diagonal_to_Smith_i_PQ_JNF ::
"nat list ⇒ nat ⇒ ('a::{bezout_ring} bezout)
⇒ ('a mat × 'a mat × 'a mat) ⇒ ('a mat × 'a mat × 'a mat)"
where
"diagonal_to_Smith_i_PQ_JNF [] i bezout (P,A,Q) = (P,A,Q)" |
"diagonal_to_Smith_i_PQ_JNF (j#xs) i bezout (P,A,Q) = (
if A $$ (i,i) dvd A $$ (j,j)
then diagonal_to_Smith_i_PQ_JNF xs i bezout (P,A,Q)
else let (p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (j,j));
A' = diagonal_step_JNF A i j d v;
(P',Q') = diagonal_step_PQ_JNF A i j bezout
in diagonal_to_Smith_i_PQ_JNF xs i bezout (P'*P,A',Q*Q')
)
"
context
includes lifting_syntax
fixes i and xs
assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
and xs: "∀j∈set xs. j < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin
declare diagonal_step_PQ.simps[simp del]
lemma HMA_diagonal_to_Smith_i_PQ_aux: "HMA_M3 (P,A,Q)
(P' :: 'a :: bezout_ring ^ 'nr :: mod_type ^ 'nr :: mod_type,
A' :: 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type,
Q' :: 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nc :: mod_type)
⟹ HMA_M3 (diagonal_to_Smith_i_PQ_JNF xs i bezout (P,A,Q))
(diagonal_to_Smith_i_PQ xs i bezout (P',A',Q'))"
using i xs
proof (induct xs i bezout "(P',A',Q')" arbitrary: P' A' Q' P A Q rule: diagonal_to_Smith_i_PQ.induct)
case (1 i bezout P' A' Q')
then show ?case by auto
next
case (2 j xs i bezout P' A' Q')
note HMA_M3[transfer_rule] = "2.prems"(1)
note i = 2(4)
note j = 2(5)
note IH1="2.hyps"(1)
note IH2="2.hyps"(2)
have j_min: "j < min CARD('nr) CARD('nc)" using j by auto
have HMA_M_AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'" using HMA_M3 by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_I j (from_nat j::'nc)"
and [transfer_rule]: "Mod_Type_Connect.HMA_I j (from_nat j::'nr)"
by (metis Mod_Type_Connect.HMA_I_def j_min min.strict_boundedE to_nat_from_nat_id)+
have [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nc)"
and [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nr)"
by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE to_nat_from_nat_id)+
have [transfer_rule]: "A $$ (i, i) = A' $h from_nat i $h from_nat i"
proof -
have "A $$ (i,i) = index_hma A' (from_nat i) (from_nat i)" by (transfer, simp)
also have "... = A' $h from_nat i $h from_nat i" unfolding index_hma_def by auto
finally show ?thesis .
qed
have [transfer_rule]: "A $$ (j, j) = A' $h from_nat j $h from_nat j"
proof -
have "A $$ (j,j) = index_hma A' (from_nat j) (from_nat j)" by (transfer, simp)
also have "... = A' $h from_nat j $h from_nat j" unfolding index_hma_def by auto
finally show ?thesis .
qed
show ?case
proof (cases "A $$ (i, i) dvd A $$ (j, j)")
case True
hence "A' $h from_nat i $h from_nat i dvd A' $h from_nat j $h from_nat j" by transfer
then show ?thesis using True IH1 HMA_M3 i j by auto
next
case False
obtain p q u v d where b: "(p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (j,j))"
by (metis prod_cases5)
let ?A'_JNF = "diagonal_step_JNF A i j d v"
obtain P''_JNF Q''_JNF where P''Q''_JNF: "(P''_JNF,Q''_JNF) = diagonal_step_PQ_JNF A i j bezout"
by (metis surjective_pairing)
have not_dvd: "¬ A' $h from_nat i $h from_nat i dvd A' $h from_nat j $h from_nat j" using False by transfer
let ?A' = "diagonal_step A' i j d v"
obtain P'' Q'' where P''Q'': "(P'',Q'') = diagonal_step_PQ A' i j bezout"
by (metis surjective_pairing)
have b2: "(p, q, u, v, d) = bezout (A' $h from_nat i $h from_nat i) (A' $h from_nat j $h from_nat j)"
using b by (transfer,auto)
let ?D_HA = "diagonal_to_Smith_i_PQ xs i bezout (P''**P',?A',Q'**Q'')"
let ?D_JNF = "diagonal_to_Smith_i_PQ_JNF xs i bezout (P''_JNF*P,?A'_JNF,Q*Q''_JNF)"
have rw_1: "diagonal_to_Smith_i_PQ_JNF (j # xs) i bezout (P, A, Q) = ?D_JNF"
using False b P''Q''_JNF
by (auto, unfold split_beta, metis fst_conv snd_conv)
have rw_2: "diagonal_to_Smith_i_PQ (j # xs) i bezout (P', A', Q') = ?D_HA"
using not_dvd b2 P''Q'' by (auto, unfold split_beta, metis fst_conv snd_conv)
have "HMA_M3 ?D_JNF ?D_HA"
proof (rule IH2[OF not_dvd b2], auto)
have j: "j < min CARD('nr) CARD('nc)" using j by auto
have [transfer_rule]: "rel_prod Mod_Type_Connect.HMA_M Mod_Type_Connect.HMA_M
(diagonal_step_PQ_JNF A i j bezout) (diagonal_step_PQ A' i j bezout)"
using HMA_diagonal_step_PQ[OF i j] HMA_M_AA' unfolding rel_fun_def by auto
hence [transfer_rule]: "Mod_Type_Connect.HMA_M P''_JNF P''"
and [transfer_rule]: "Mod_Type_Connect.HMA_M Q''_JNF Q''"
using P''Q'' P''Q''_JNF unfolding rel_prod_conv split_beta
by (metis fst_conv, metis snd_conv)
have [transfer_rule]: "Mod_Type_Connect.HMA_M P P'" using HMA_M3 by auto
show "Mod_Type_Connect.HMA_M (P''_JNF * P) (P'' ** P')"
by (transfer_prover_start, transfer_step+, auto)
show "Mod_Type_Connect.HMA_M (diagonal_step_JNF A i j d v) (diagonal_step A' i j d v)"
using HMA_diagonal_step[OF i j] HMA_M_AA' unfolding rel_fun_def by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_M Q Q'" using HMA_M3 by auto
show "Mod_Type_Connect.HMA_M (Q * Q''_JNF) (Q' ** Q'')"
by (transfer_prover_start, transfer_step+, auto)
qed (insert i j P''Q'', auto)
then show ?thesis using rw_1 rw_2 by auto
qed
qed
lemma HMA_diagonal_to_Smith_i_PQ[transfer_rule]:
"((=)
===> (HMA_M3 :: (_ ⇒ (_×('a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type) × _) ⇒_))
===> HMA_M3) (diagonal_to_Smith_i_PQ_JNF xs i) (diagonal_to_Smith_i_PQ xs i)"
proof (intro rel_funI, goal_cases)
case (1 x y bezout bezout')
then show ?case using HMA_diagonal_to_Smith_i_PQ_aux
by (auto, smt HMA_M3.elims(2))
qed
end
fun Diagonal_to_Smith_row_i_PQ_JNF
where "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P,A,Q)
= diagonal_to_Smith_i_PQ_JNF [i + 1..<min (dim_row A) (dim_col A)] i bezout (P,A,Q)"
declare Diagonal_to_Smith_row_i_PQ_JNF.simps[simp del]
lemmas Diagonal_to_Smith_row_i_PQ_JNF_def = Diagonal_to_Smith_row_i_PQ_JNF.simps
context
includes lifting_syntax
fixes i
assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin
lemma HMA_Diagonal_to_Smith_row_i_PQ[transfer_rule]:
"((=) ===> (HMA_M3 :: (_ ⇒ (_ × ('a::bezout_ring^'nc::mod_type^'nr::mod_type) × _) ⇒ _)) ===> HMA_M3)
(Diagonal_to_Smith_row_i_PQ_JNF i) (Diagonal_to_Smith_row_i_PQ i)"
proof (intro rel_funI, clarify, goal_cases)
case (1 _ bezout P A Q P' A' Q')
note HMA_M3[transfer_rule] = 1
let ?xs1="[i + 1..<min (dim_row A) (dim_col A)]"
let ?xs2="[i + 1..<min (nrows A') (ncols A')]"
have xs_eq[transfer_rule]: "?xs1 = ?xs2"
using HMA_M3
by (auto intro: arg_cong2[where f = upt]
simp: Mod_Type_Connect.dim_col_transfer_rule Mod_Type_Connect.dim_row_transfer_rule
nrows_def ncols_def)
have j_xs: "∀j∈set ?xs1. j < min CARD('nr) CARD('nc)" using i
by (metis atLeastLessThan_iff ncols_def nrows_def set_upt xs_eq)
have rel: "HMA_M3 (diagonal_to_Smith_i_PQ_JNF ?xs1 i bezout (P,A,Q))
(diagonal_to_Smith_i_PQ ?xs1 i bezout (P',A',Q'))"
using HMA_diagonal_to_Smith_i_PQ[OF i j_xs] HMA_M3 unfolding rel_fun_def by blast
then show ?case
unfolding Diagonal_to_Smith_row_i_PQ_JNF_def Diagonal_to_Smith_row_i_PQ_def
by (metis Suc_eq_plus1 xs_eq)
qed
end
fun diagonal_to_Smith_aux_PQ_JNF
where
"diagonal_to_Smith_aux_PQ_JNF [] bezout (P,A,Q) = (P,A,Q)" |
"diagonal_to_Smith_aux_PQ_JNF (i#xs) bezout (P,A,Q)
= diagonal_to_Smith_aux_PQ_JNF xs bezout (Diagonal_to_Smith_row_i_PQ_JNF i bezout (P,A,Q))"
context
includes lifting_syntax
fixes xs
assumes xs: "∀j∈set xs. j < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin
lemma HMA_diagonal_to_Smith_aux_PQ_JNF[transfer_rule]:
"((=) ===> (HMA_M3 :: (_ ⇒ (_ × ('a::bezout_ring^'nc::mod_type^'nr::mod_type) × _) ⇒ _)) ===> HMA_M3)
(diagonal_to_Smith_aux_PQ_JNF xs) (diagonal_to_Smith_aux_PQ xs)"
proof (intro rel_funI, clarify, goal_cases)
case (1 _ bezout P A Q P' A' Q')
note HMA_M3[transfer_rule] = 1
show ?case
using xs HMA_M3
proof (induct xs arbitrary: P' A' Q' P A Q)
case Nil
then show ?case by auto
next
case (Cons i xs)
note IH = Cons(1)
note HMA_M3 = Cons.prems(2)
have i: "i < min CARD('nr) CARD('nc)" using Cons.prems by auto
let ?D_JNF = "(Diagonal_to_Smith_row_i_PQ_JNF i bezout (P, A, Q))"
let ?D_HA = "(Diagonal_to_Smith_row_i_PQ i bezout (P', A', Q'))"
have rw_1: "diagonal_to_Smith_aux_PQ_JNF (i # xs) bezout (P, A, Q)
= diagonal_to_Smith_aux_PQ_JNF xs bezout ?D_JNF" by auto
have rw_2: "diagonal_to_Smith_aux_PQ (i # xs) bezout (P', A', Q')
= diagonal_to_Smith_aux_PQ xs bezout ?D_HA" by auto
have "HMA_M3 ?D_JNF ?D_HA"
using HMA_Diagonal_to_Smith_row_i_PQ[OF i] HMA_M3 unfolding rel_fun_def by blast
then show ?case
by (auto, smt Cons.hyps HMA_M3.elims(2) list.set_intros(2) local.Cons(2))
qed
qed
end
fun diagonal_to_Smith_PQ_JNF
where "diagonal_to_Smith_PQ_JNF A bezout
= diagonal_to_Smith_aux_PQ_JNF [0..<min (dim_row A) (dim_col A) - 1]
bezout (1⇩m (dim_row A),A,1⇩m (dim_col A))"
declare diagonal_to_Smith_PQ_JNF.simps[simp del]
lemmas diagonal_to_Smith_PQ_JNF_def = diagonal_to_Smith_PQ_JNF.simps
lemma diagonal_step_PQ_JNF_dim:
assumes A: "A ∈ carrier_mat m n"
and d: "diagonal_step_PQ_JNF A i j bezout = (P,Q)"
shows "P ∈ carrier_mat m m ∧ Q ∈ carrier_mat n n"
using A d unfolding diagonal_step_PQ_JNF_def split_beta Let_def by auto
lemma diagonal_step_JNF_dim:
assumes A: "A ∈ carrier_mat m n"
shows "diagonal_step_JNF A i j d v ∈ carrier_mat m n"
using A unfolding diagonal_step_JNF_def by auto
lemma diagonal_to_Smith_i_PQ_JNF_dim:
assumes "P' ∈ carrier_mat m m ∧ A' ∈ carrier_mat m n ∧ Q' ∈ carrier_mat n n"
and "diagonal_to_Smith_i_PQ_JNF xs i bezout (P',A',Q') = (P,A,Q)"
shows "P ∈ carrier_mat m m ∧ A ∈ carrier_mat m n ∧ Q ∈ carrier_mat n n"
using assms
proof (induct xs i bezout "(P',A',Q')" arbitrary: P A Q P' A' Q' rule: diagonal_to_Smith_i_PQ_JNF.induct)
case (1 i bezout P A Q)
then show ?case by auto
next
case (2 j xs i bezout P' A' Q')
show ?case
proof (cases "A' $$ (i, i) dvd A' $$ (j, j)")
case True
then show ?thesis using 2 by auto
next
case False
obtain p q u v d where b: "(p, q, u, v, d) = bezout (A' $$ (i,i)) (A' $$ (j,j))"
by (metis prod_cases5)
let ?A' = "diagonal_step_JNF A' i j d v"
obtain P'' Q'' where P''Q'': "(P'',Q'') = diagonal_step_PQ_JNF A' i j bezout"
by (metis surjective_pairing)
let ?A' = "diagonal_step_JNF A' i j d v"
let ?D_JNF = "diagonal_to_Smith_i_PQ_JNF xs i bezout (P''*P',?A',Q'*Q'')"
have rw_1: "diagonal_to_Smith_i_PQ_JNF (j # xs) i bezout (P', A', Q') = ?D_JNF"
using False b P''Q''
by (auto, unfold split_beta, metis fst_conv snd_conv)
show ?thesis
proof (rule "2.hyps"(2)[OF False b])
show "?D_JNF = (P,A,Q)" using rw_1 2 by auto
have "P'' ∈ carrier_mat m m" and "Q'' ∈ carrier_mat n n"
using diagonal_step_PQ_JNF_dim[OF _ P''Q''[symmetric]] "2.prems" by auto
thus "P'' * P' ∈ carrier_mat m m ∧ ?A' ∈ carrier_mat m n ∧ Q' * Q'' ∈ carrier_mat n n"
using diagonal_step_JNF_dim 2 by (metis mult_carrier_mat)
qed (insert P''Q'', auto)
qed
qed
lemma Diagonal_to_Smith_row_i_PQ_JNF_dim:
assumes "P' ∈ carrier_mat m m ∧ A' ∈ carrier_mat m n ∧ Q' ∈ carrier_mat n n"
and "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P',A',Q') = (P,A,Q)"
shows "P ∈ carrier_mat m m ∧ A ∈ carrier_mat m n ∧ Q ∈ carrier_mat n n"
by (rule diagonal_to_Smith_i_PQ_JNF_dim, insert assms,
auto simp add: Diagonal_to_Smith_row_i_PQ_JNF_def)
lemma diagonal_to_Smith_aux_PQ_JNF_dim:
assumes "P' ∈ carrier_mat m m ∧ A' ∈ carrier_mat m n ∧ Q' ∈ carrier_mat n n"
and "diagonal_to_Smith_aux_PQ_JNF xs bezout (P',A',Q') = (P,A,Q)"
shows "P ∈ carrier_mat m m ∧ A ∈ carrier_mat m n ∧ Q ∈ carrier_mat n n"
using assms
proof (induct xs bezout "(P',A',Q')" arbitrary: P A Q P' A' Q' rule: diagonal_to_Smith_aux_PQ_JNF.induct)
case (1 bezout P A Q)
then show ?case by simp
next
case (2 i xs bezout P' A' Q')
let ?D="(Diagonal_to_Smith_row_i_PQ_JNF i bezout (P', A', Q'))"
have "diagonal_to_Smith_aux_PQ_JNF (i # xs) bezout (P', A', Q') =
diagonal_to_Smith_aux_PQ_JNF xs bezout ?D" by auto
hence *: "... = (P,A,Q)" using 2 by auto
let ?P="fst ?D"
let ?S="fst (snd ?D)"
let ?Q="snd (snd ?D)"
show ?case
proof (rule "2.hyps")
show "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P', A', Q') = (?P,?S,?Q)" by auto
show "diagonal_to_Smith_aux_PQ_JNF xs bezout (?P, ?S, ?Q) = (P, A, Q)" using * by simp
show "?P ∈ carrier_mat m m ∧ ?S ∈ carrier_mat m n ∧ ?Q ∈ carrier_mat n n"
by (rule Diagonal_to_Smith_row_i_PQ_JNF_dim, insert 2, auto)
qed
qed
lemma diagonal_to_Smith_PQ_JNF_dim:
assumes "A ∈ carrier_mat m n"
and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P,S,Q)"
shows "P ∈ carrier_mat m m ∧ S ∈ carrier_mat m n ∧ Q ∈ carrier_mat n n"
by (rule diagonal_to_Smith_aux_PQ_JNF_dim, insert assms,
auto simp add: diagonal_to_Smith_PQ_JNF_def)
context
includes lifting_syntax
begin
lemma HMA_diagonal_to_Smith_PQ_JNF[transfer_rule]:
"((Mod_Type_Connect.HMA_M) ===> (=) ===> HMA_M3) (diagonal_to_Smith_PQ_JNF) (diagonal_to_Smith_PQ)"
proof (intro rel_funI, clarify, goal_cases)
case (1 A A' _ bezout)
let ?xs1 = "[0..<min (dim_row A) (dim_col A) - 1]"
let ?xs2 = "[0..<min (nrows A') (ncols A') - 1]"
let ?PAQ="(1⇩m (dim_row A), A, 1⇩m (dim_col A))"
have dr: "dim_row A = CARD('c)"
using 1 Mod_Type_Connect.dim_row_transfer_rule by blast
have dc: "dim_col A = CARD('b)"
using 1 Mod_Type_Connect.dim_col_transfer_rule by blast
have xs_eq: "?xs1 = ?xs2"
by (simp add: dc dr ncols_def nrows_def)
have j_xs: "∀j∈set ?xs1. j < min CARD('c) CARD('b)"
using dc dr less_imp_diff_less by auto
let ?D_JNF = "diagonal_to_Smith_aux_PQ_JNF ?xs1 bezout ?PAQ"
let ?D_HA = "diagonal_to_Smith_aux_PQ ?xs1 bezout (mat 1, A', mat 1)"
have mat_rel_init: "HMA_M3 ?PAQ (mat 1, A', mat 1)"
proof -
have "Mod_Type_Connect.HMA_M (1⇩m (dim_row A)) (mat 1::'a^'c::mod_type^'c::mod_type)"
unfolding dr by (transfer_prover_start,transfer_step, auto)
moreover have "Mod_Type_Connect.HMA_M (1⇩m (dim_col A)) (mat 1::'a^'b::mod_type^'b::mod_type)"
unfolding dc by (transfer_prover_start,transfer_step, auto)
ultimately show ?thesis using 1 by auto
qed
have "HMA_M3 ?D_JNF ?D_HA"
using HMA_diagonal_to_Smith_aux_PQ_JNF[OF j_xs] mat_rel_init unfolding rel_fun_def by blast
then show ?case using xs_eq unfolding diagonal_to_Smith_PQ_JNF_def diagonal_to_Smith_PQ_def
by auto
qed
end
subsection ‹Applying local type definitions›
text ‹Now we get the soundness lemma in JNF, via the one in HOL Analysis. I need transfer rules
and local type definitions.›
context
includes lifting_syntax
begin
private lemma diagonal_to_Smith_PQ_JNF_with_types:
assumes A: "A ∈ carrier_mat CARD('nr::mod_type) CARD('nc::mod_type)"
and S: "S ∈ carrier_mat CARD('nr) CARD('nc)"
and P: "P ∈ carrier_mat CARD('nr) CARD('nr)"
and Q: "Q ∈ carrier_mat CARD('nc) CARD('nc)"
and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q)"
and d:"isDiagonal_mat A" and ib: "is_bezout_ext bezout"
shows "S = P * A * Q ∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat S"
proof -
let ?P = "Mod_Type_Connect.to_hma⇩m P::'a^'nr::mod_type^'nr::mod_type"
let ?A = "Mod_Type_Connect.to_hma⇩m A::'a^'nc::mod_type^'nr::mod_type"
let ?Q = "Mod_Type_Connect.to_hma⇩m Q::'a^'nc::mod_type^'nc::mod_type"
let ?S = "Mod_Type_Connect.to_hma⇩m S::'a^'nc::mod_type^'nr::mod_type"
have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?A"
by (simp add: Mod_Type_Connect.HMA_M_def A)
moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M P ?P"
by (simp add: Mod_Type_Connect.HMA_M_def P)
moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M Q ?Q"
by (simp add: Mod_Type_Connect.HMA_M_def Q)
moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M S ?S"
by (simp add: Mod_Type_Connect.HMA_M_def S)
ultimately have [transfer_rule]: "HMA_M3 (P,S,Q) (?P,?S,?Q)" by simp
have [transfer_rule]: "bezout = bezout" ..
have PSQ2: "(?P,?S,?Q) = diagonal_to_Smith_PQ ?A bezout" by (transfer, insert PSQ, auto)
have "?S = ?P**?A**?Q ∧ invertible ?P ∧ invertible ?Q ∧ Smith_normal_form ?S"
by (rule diagonal_to_Smith_PQ'[OF _ ib PSQ2], transfer, auto simp add: d)
with this[untransferred] show ?thesis by auto
qed
private lemma diagonal_to_Smith_PQ_JNF_mod_ring_with_types:
assumes A: "A ∈ carrier_mat CARD('nr::nontriv mod_ring) CARD('nc::nontriv mod_ring)"
and S: "S ∈ carrier_mat CARD('nr mod_ring) CARD('nc mod_ring)"
and P: "P ∈ carrier_mat CARD('nr mod_ring) CARD('nr mod_ring)"
and Q: "Q ∈ carrier_mat CARD('nc mod_ring) CARD('nc mod_ring)"
and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q)"
and d:"isDiagonal_mat A" and ib: "is_bezout_ext bezout"
shows "S = P * A * Q ∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat S"
by (rule diagonal_to_Smith_PQ_JNF_with_types[OF assms])
thm diagonal_to_Smith_PQ_JNF_mod_ring_with_types[unfolded CARD_mod_ring,
internalize_sort "'nr::nontriv"]
private lemma diagonal_to_Smith_PQ_JNF_internalized_first:
"class.nontriv TYPE('a::type) ⟹
A ∈ carrier_mat CARD('a) CARD('nc::nontriv) ⟹
S ∈ carrier_mat CARD('a) CARD('nc) ⟹
P ∈ carrier_mat CARD('a) CARD('a) ⟹
Q ∈ carrier_mat CARD('nc) CARD('nc) ⟹
diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q) ⟹
isDiagonal_mat A ⟹ is_bezout_ext bezout ⟹
S = P * A * Q ∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat S"
using diagonal_to_Smith_PQ_JNF_mod_ring_with_types[unfolded CARD_mod_ring,
internalize_sort "'nr::nontriv"] by blast
private lemma diagonal_to_Smith_PQ_JNF_internalized:
"class.nontriv TYPE('c::type) ⟹
class.nontriv TYPE('a::type) ⟹
A ∈ carrier_mat CARD('a) CARD('c) ⟹
S ∈ carrier_mat CARD('a) CARD('c) ⟹
P ∈ carrier_mat CARD('a) CARD('a) ⟹
Q ∈ carrier_mat CARD('c) CARD('c) ⟹
diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q) ⟹
isDiagonal_mat A ⟹ is_bezout_ext bezout ⟹
S = P * A * Q ∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat S"
using diagonal_to_Smith_PQ_JNF_internalized_first[internalize_sort "'nc::nontriv"] by blast
context
fixes m::nat and n::nat
assumes local_typedef1: "∃(Rep :: ('b ⇒ int)) Abs. type_definition Rep Abs {0..<m :: int}"
assumes local_typedef2: "∃(Rep :: ('c ⇒ int)) Abs. type_definition Rep Abs {0..<n :: int}"
and m: "m>1"
and n: "n>1"
begin
lemma type_to_set1:
shows "class.nontriv TYPE('b)" (is ?a) and "m=CARD('b)" (is ?b)
proof -
from local_typedef1 obtain Rep::"('b ⇒ int)" and Abs
where t: "type_definition Rep Abs {0..<m :: int}" by auto
have "card (UNIV :: 'b set) = card {0..<m}" using t type_definition.card by fastforce
also have "... = m" by auto
finally show ?b ..
then show ?a unfolding class.nontriv_def using m by auto
qed
lemma type_to_set2:
shows "class.nontriv TYPE('c)" (is ?a) and "n=CARD('c)" (is ?b)
proof -
from local_typedef2 obtain Rep::"('c ⇒ int)" and Abs
where t: "type_definition Rep Abs {0..<n :: int}" by blast
have "card (UNIV :: 'c set) = card {0..<n}" using t type_definition.card by force
also have "... = n" by auto
finally show ?b ..
then show ?a unfolding class.nontriv_def using n by auto
qed
lemma diagonal_to_Smith_PQ_JNF_local_typedef:
assumes A: "isDiagonal_mat A" and ib: "is_bezout_ext bezout"
and A_dim: "A ∈ carrier_mat m n"
assumes PSQ: "(P,S,Q) = diagonal_to_Smith_PQ_JNF A bezout"
shows "S = P*A*Q ∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat S
∧ P ∈ carrier_mat m m ∧ S ∈ carrier_mat m n ∧ Q ∈ carrier_mat n n"
proof -
have dim_matrices: "P ∈ carrier_mat m m ∧ S ∈ carrier_mat m n ∧ Q ∈ carrier_mat n n"
by (rule diagonal_to_Smith_PQ_JNF_dim[OF A_dim PSQ[symmetric]])
show ?thesis
using diagonal_to_Smith_PQ_JNF_internalized[where ?'c='c, where ?'a='b,
OF type_to_set2(1) type_to_set(1), of m A S P Q]
unfolding type_to_set1(2)[symmetric] type_to_set2(2)[symmetric]
using assms m dim_matrices local_typedef1 by auto
qed
end
end
context
begin
private lemma diagonal_to_Smith_PQ_JNF_canceled_first:
"∃Rep Abs. type_definition Rep Abs {0..<int n} ⟹ {0..<int m} ≠ {} ⟹
1 < m ⟹ 1 < n ⟹ isDiagonal_mat A ⟹ is_bezout_ext bezout ⟹
A ∈ carrier_mat m n ⟹ (P, S, Q) = diagonal_to_Smith_PQ_JNF A bezout ⟹
S = P * A * Q ∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat S
∧ P ∈ carrier_mat m m ∧ S ∈ carrier_mat m n ∧ Q ∈ carrier_mat n n"
using diagonal_to_Smith_PQ_JNF_local_typedef[cancel_type_definition] by blast
private lemma diagonal_to_Smith_PQ_JNF_canceled_both:
"{0..<int n} ≠ {} ⟹ {0..<int m} ≠ {} ⟹ 1 < m ⟹ 1 < n ⟹
isDiagonal_mat A ⟹ is_bezout_ext bezout ⟹ A ∈ carrier_mat m n ⟹
(P, S, Q) = diagonal_to_Smith_PQ_JNF A bezout ⟹ S = P * A * Q ∧
invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat S
∧ P ∈ carrier_mat m m ∧ S ∈ carrier_mat m n ∧ Q ∈ carrier_mat n n"
using diagonal_to_Smith_PQ_JNF_canceled_first[cancel_type_definition] by blast
subsection ‹The final result›
lemma diagonal_to_Smith_PQ_JNF:
assumes A: "isDiagonal_mat A" and ib: "is_bezout_ext bezout"
and "A ∈ carrier_mat m n"
and PBQ: "(P,S,Q) = diagonal_to_Smith_PQ_JNF A bezout"
and n: "n>1" and m: "m>1"
shows "S = P*A*Q ∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat S
∧ P ∈ carrier_mat m m ∧ S ∈ carrier_mat m n ∧ Q ∈ carrier_mat n n"
using diagonal_to_Smith_PQ_JNF_canceled_both[OF _ _ m n] using assms by force
end
end
Theory SNF_Algorithm_Two_Steps_JNF
section ‹Smith normal form algorithm based on two steps in JNF›
theory SNF_Algorithm_Two_Steps_JNF
imports
Diagonalize
Diagonal_To_Smith_JNF
begin
subsection ‹Moving the result from HOL Analysis to JNF›
context diagonalize
begin
definition "Smith_normal_form_of_JNF A bezout = (
let (P'',D,Q'') = diagonalize_JNF A bezout;
(P',S,Q') = diagonal_to_Smith_PQ_JNF D bezout
in (P'*P'',S,Q''*Q')
)"
lemma Smith_normal_form_of_JNF_soundness:
assumes b: "is_bezout_ext bezout" and A: "A ∈ carrier_mat m n"
and n: "1 < n" and m: "1 < m"
and PSQ: "Smith_normal_form_of_JNF A bezout = (P,S,Q)"
shows "S = P*A*Q ∧ invertible_mat P ∧ invertible_mat Q ∧ Smith_normal_form_mat S
∧ P ∈ carrier_mat m m ∧ S ∈ carrier_mat m n ∧ Q∈ carrier_mat n n"
proof -
obtain P'' D Q'' where PDQ_diag: "(P'',D,Q'') = diagonalize_JNF A bezout"
by (metis prod_cases3)
have 1: "invertible_mat P'' ∧ invertible_mat Q'' ∧ isDiagonal_mat D ∧ D = P''*A*Q''
∧ P'' ∈ carrier_mat m m ∧ Q'' ∈ carrier_mat n n ∧ D ∈ carrier_mat m n"
using soundness_diagonalize_JNF'[OF b A PDQ_diag[symmetric]] by auto
obtain P' Q' where PSQ_D: "(P',S,Q') = diagonal_to_Smith_PQ_JNF D bezout"
using PSQ PDQ_diag unfolding Smith_normal_form_of_JNF_def Let_def split_beta
by (metis Pair_inject prod.collapse)
have 2: "invertible_mat P' ∧ invertible_mat Q' ∧ Smith_normal_form_mat S ∧ S = P'*D*Q'
∧ P' ∈ carrier_mat m m ∧ Q' ∈ carrier_mat n n ∧ S ∈ carrier_mat m n"
using diagonal_to_Smith_PQ_JNF[OF _ b _ PSQ_D n m] 1 n m by auto
have P: "P = P'*P''"
by (metis (no_types, lifting) PDQ_diag PSQ PSQ_D Smith_normal_form_of_JNF_def fst_conv prod.simps(2))
have Q: "Q = Q''*Q'"
by (metis (no_types, lifting) PDQ_diag PSQ PSQ_D Smith_normal_form_of_JNF_def snd_conv prod.simps(2))
have "S = P'*(P''*A*Q'')*Q'" using 1 2 by auto
also have "... = (P'*P'')*A*(Q''*Q')"
by (smt "1" "2" A assoc_mult_mat carrier_matD carrier_mat_triv index_mult_mat)
finally have "S = (P' * P'') * A * (Q'' * Q')" .
moreover have "invertible_mat P" unfolding P by (rule invertible_mult_JNF, insert 1 2, auto)
moreover have "invertible_mat Q" unfolding Q by (rule invertible_mult_JNF, insert 1 2, auto)
ultimately show ?thesis using 1 2 P Q by auto
qed
end
end
Theory SNF_Algorithm
section ‹A general algorithm to transform a matrix into its Smith normal form›
theory SNF_Algorithm
imports
Smith_Normal_Form_JNF
begin
text ‹This theory presents an executable algorithm to transform a matrix
to its Smith normal form.›
subsection ‹Previous definitions and lemmas›
definition "is_SNF A R = (case R of (P,S,Q) ⇒
P ∈ carrier_mat (dim_row A) (dim_row A) ∧
Q ∈ carrier_mat (dim_col A) (dim_col A)
∧ invertible_mat P ∧ invertible_mat Q
∧ Smith_normal_form_mat S ∧ S = P * A * Q)"
lemma is_SNF_intro:
assumes "P ∈ carrier_mat (dim_row A) (dim_row A)"
and "Q ∈ carrier_mat (dim_col A) (dim_col A) "
and "invertible_mat P" and "invertible_mat Q"
and "Smith_normal_form_mat S" and "S = P * A * Q"
shows "is_SNF A (P,S,Q)" using assms unfolding is_SNF_def by auto
lemma Smith_1xn_two_matrices:
fixes A :: "'a::comm_ring_1 mat"
assumes A: "A ∈ carrier_mat 1 n"
and PSQ: "(P,S,Q) = (Smith_1xn A)"
and is_SNF: "is_SNF A (Smith_1xn A)"
shows "∃Smith_1xn'. is_SNF A (1⇩m 1, (Smith_1xn' A))"
proof -
let ?Q = "P$$(0,0) ⋅⇩m Q"
have P00_dvd_1: "P $$ (0, 0) dvd 1"
by (metis (mono_tags, lifting) assms carrier_matD(1) determinant_one_element
invertible_iff_is_unit_JNF is_SNF_def prod.simps(2))
have "is_SNF A (1⇩m 1,S,?Q)"
proof (rule is_SNF_intro)
show "invertible_mat (P $$ (0, 0) ⋅⇩m Q)"
by (rule invertible_mat_smult_mat, insert P00_dvd_1 assms, auto simp add: is_SNF_def)
show "S = 1⇩m 1 * A * (P $$ (0, 0) ⋅⇩m Q)"
by (smt A PSQ is_SNF carrier_matD(2) index_mult_mat(2) index_one_mat(2) left_mult_one_mat
mult_smult_assoc_mat mult_smult_distrib smult_mat_mat_one_element is_SNF_def split_conv)
qed (insert assms, auto simp add: is_SNF_def)
thus ?thesis by auto
qed
lemma Smith_1xn_two_matrices_all:
assumes is_SNF: "∀(A::'a::comm_ring_1 mat) ∈ carrier_mat 1 n. is_SNF A (Smith_1xn A)"
shows "∃Smith_1xn'. ∀(A::'a::comm_ring_1 mat) ∈ carrier_mat 1 n. is_SNF A (1⇩m 1, (Smith_1xn' A))"
proof -
let ?Smith_1xn' = "λA. let (P,S,Q) = (Smith_1xn A) in (S, P $$ (0, 0) ⋅⇩m Q)"
show ?thesis by (rule exI[of _ ?Smith_1xn']) (smt Smith_1xn_two_matrices assms carrier_matD
carrier_matI case_prodE determinant_one_element index_smult_mat(2,3) invertible_iff_is_unit_JNF
invertible_mat_smult_mat smult_mat_mat_one_element left_mult_one_mat is_SNF_def
mult_smult_assoc_mat mult_smult_distrib prod.simps(2))
qed
subsection ‹Previous operations›
context
assumes "SORT_CONSTRAINT('a::comm_ring_1)"
begin
definition is_div_op :: "('a⇒'a⇒'a) ⇒bool"
where "is_div_op div_op = (∀a b. b dvd a ⟶ div_op a b * b = a)"
lemma div_op_SOME: "is_div_op (λa b. (SOME k. k * b = a))"
proof (unfold is_div_op_def, rule+)
fix a b::'a assume dvd: "b dvd a"
show "(SOME k. k * b = a) * b = a" by (rule someI_ex, insert dvd dvd_def) (metis dvdE mult.commute)
qed
fun reduce_column_aux :: "('a⇒'a⇒'a) ⇒ nat list ⇒ 'a mat ⇒ ('a mat × 'a mat) ⇒ ('a mat × 'a mat)"
where "reduce_column_aux div_op [] H (P,K) = (P,K)"
| "reduce_column_aux div_op (i#xs) H (P,K) = (
let k = div_op (H$$(i,0)) (H $$ (0, 0));
P' = addrow_mat (dim_row H) (-k) i 0;
K' = addrow (-k) i 0 K
in reduce_column_aux div_op xs H (P'*P,K')
)"
definition "reduce_column div_op H = reduce_column_aux div_op [2..<dim_row H] H (1⇩m (dim_row H),H)"
lemma reduce_column_aux:
assumes H: "H ∈ carrier_mat m n"
and P_init: "P_init ∈ carrier_mat m m"
and K_init: "K_init ∈ carrier_mat m n"
and P_init_H_K_init: "P_init * H = K_init"
and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)"
and m: "0 < m"
and inv_P: "invertible_mat P_init"
and xs: "0 ∉ set xs"
shows "P ∈ carrier_mat m m ∧ K ∈ carrier_mat m n ∧ P * H = K ∧ invertible_mat P"
using assms
unfolding reduce_column_def
proof (induct div_op xs H "(P_init,K_init)" arbitrary: P_init K_init rule: reduce_column_aux.induct)
case (1 div_op H P K)
then show ?case by simp
next
case (2 div_op i xs H P_init K_init)
show ?case
proof (rule "2.hyps")
let ?x = "div_op (H $$ (i, 0)) (H $$ (0, 0))"
let ?xa = "addrow_mat (dim_row H) (- ?x) i 0"
let ?xb = "addrow (- ?x) i 0 K_init"
show "(P, K) = reduce_column_aux div_op xs H (?xa * P_init, ?xb)"
using "2.prems" by (auto simp add: Let_def)
show "?xa * P_init ∈ carrier_mat m m" using "2"(2) "2"(3) by auto
show "0 ∉ set xs" using "2.prems" by auto
have "?xa * K_init = ?xb"
by (rule addrow_mat[symmetric], insert "2.prems", auto)
thus "?xa * P_init * H = ?xb"
by (metis (no_types, lifting) "2"(5) "2.prems"(1) "2.prems"(2) addrow_mat_carrier
assoc_mult_mat carrier_matD(1))
show "invertible_mat (?xa * P_init)"
proof (rule invertible_mult_JNF)
show xa: "?xa ∈ carrier_mat m m" using "2"(2) by auto
have "Determinant.det ?xa = 1" by (rule det_addrow_mat, insert "2.prems", auto)
thus "invertible_mat ?xa" unfolding invertible_iff_is_unit_JNF[OF xa] by simp
qed (auto simp add: "2.prems")
qed(auto simp add: "2.prems")
qed
lemma reduce_column_aux_preserves:
assumes H: "H ∈ carrier_mat m n"
and P_init: "P_init ∈ carrier_mat m m"
and K_init: "K_init ∈ carrier_mat m n"
and P_init_H_K_init: "P_init * H = K_init"
and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)"
and m: "0 < m"
and inv_P: "invertible_mat P_init"
and xs: "0 ∉ set xs" and i: "i ∉ set xs" and im: "i<m"
shows "Matrix.row K i = Matrix.row K_init i"
using PK_H inv_P H P_init K_init m xs i
unfolding reduce_column_def
proof (induct div_op xs H "(P_init,K_init)" arbitrary: P_init K_init K rule: reduce_column_aux.induct)
case (1 div_op H P K)
then show ?case by auto
next
case (2 div_op x xs H P_init K_init)
thm "2.prems"
"2.hyps"
let ?x = "div_op (H $$ (x, 0)) (H $$ (0, 0))"
let ?xa = "addrow_mat (dim_row H) (- ?x) x 0"
let ?xb = "addrow (- ?x) x 0 K_init"
have IH: "Matrix.row K i = Matrix.row ?xb i"
proof (rule "2.hyps")
show "(P, K) = reduce_column_aux div_op xs H (?xa * P_init, ?xb)"
using "2.prems" by (auto simp add: Let_def)
show "?xa * P_init ∈ carrier_mat m m"
using "2"(4) "2"(5) by auto
have "?xa * K_init = ?xb"
by (rule addrow_mat[symmetric], insert "2.prems", auto)
show "invertible_mat (?xa * P_init)"
proof (rule invertible_mult_JNF)
show xa: "?xa ∈ carrier_mat m m" using "2.prems" by auto
have "Determinant.det ?xa = 1" by (rule det_addrow_mat, insert "2.prems", auto)
thus "invertible_mat ?xa" unfolding invertible_iff_is_unit_JNF[OF xa] by simp
qed (auto simp add: "2.prems")
show "i ∉ set xs" using "2"(9) by auto
show "0 ∉ set xs" using "2"(8) by auto
qed(auto simp add: "2.prems")
also have "... = Matrix.row K_init i"
by (rule eq_vecI, auto, insert "2" "2.prems" im, auto)
finally show ?case .
qed
lemma reduce_column_aux_index':
assumes H: "H ∈ carrier_mat m n"
and P_init: "P_init ∈ carrier_mat m m"
and K_init: "K_init ∈ carrier_mat m n"
and P_init_H_K_init: "P_init * H = K_init"
and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)"
and m: "0 < m"
and inv_P: "invertible_mat P_init"
and xs: "0 ∉ set xs"
and "∀x∈set xs. x<m"
and "distinct xs"
shows "(∀i∈set xs. Matrix.row K i =
Matrix.row (addrow (-(div_op (H $$ (i, 0)) (H $$ (0, 0)))) i 0 K_init) i)"
using assms
unfolding reduce_column_def
proof (induct div_op xs H "(P_init,K_init)" arbitrary: P_init K_init K rule: reduce_column_aux.induct)
case (1 div_op H P K)
then show ?case by simp
next
case (2 div_op i xs H P_init K_init)
let ?x = "div_op (H $$ (i, 0)) (H $$ (0, 0)) "
let ?xa = "addrow_mat (dim_row H) ?x i 0"
thm "2.prems"
thm "2.hyps"
let ?xb = "addrow (- ?x) i 0 K_init"
let ?xa = "addrow_mat (dim_row H) (- ?x) i 0"
have "reduce_column_aux div_op (i#xs) H (P_init,K_init)
= reduce_column_aux div_op xs H (?xa*P_init,?xb)"
by (auto simp add: Let_def)
hence PK: "(P,K) = reduce_column_aux div_op xs H (?xa*P_init,?xb)" using "2.prems" by simp
have xa_P_init: "?xa * P_init ∈ carrier_mat m m" using "2"(2) "2"(3) by auto
have zero_notin_xs: "0 ∉ set xs" using "2.prems" by auto
have "?xa * K_init = ?xb"
by (rule addrow_mat[symmetric], insert "2.prems", auto)
hence rw: "?xa * P_init * H = ?xb"
by (metis (no_types, lifting) "2"(5) "2.prems"(1) "2.prems"(2) addrow_mat_carrier
assoc_mult_mat carrier_matD(1))
have inv_xa_P_init: "invertible_mat (?xa * P_init)"
proof (rule invertible_mult_JNF)
show xa: "?xa ∈ carrier_mat m m" using "2"(2) by auto
have "Determinant.det ?xa = 1" by (rule det_addrow_mat, insert "2.prems", auto)
thus "invertible_mat ?xa" unfolding invertible_iff_is_unit_JNF[OF xa] by simp
qed (auto simp add: "2.prems")
have i1: "i≠0" using "2.prems"(8) by auto
have i2: "i<m" by (simp add: "2.prems"(9))
have i3: "i∉set xs" using 2 by auto
have d: "distinct xs" using 2 by auto
have "∀i∈set xs. Matrix.row K i = Matrix.row (addrow (- (div_op (H $$ (i, 0)) (H $$ (0, 0))))
i 0 ?xb) i"
by (rule "2.hyps", insert xa_P_init zero_notin_xs rw inv_xa_P_init d,
auto simp add: "2.prems" Let_def)
moreover have "Matrix.row (addrow (- (div_op (H $$ (j, 0)) (H $$ (0, 0)))) j 0 ?xb) j
= Matrix.row (addrow (- (div_op (H $$ (j, 0)) (H $$ (0, 0)))) j 0 K_init) j"
(is "Matrix.row ?lhs j= Matrix.row ?rhs j")
if j: "j ∈ set xs" for j
proof (rule eq_vecI)
fix ia assume ia: "ia<dim_vec(Matrix.row ?rhs j)"
let ?k = "div_op (H $$ (j, 0)) (H $$ (0, 0))"
let ?L = "(addrow (- (div_op (H $$ (i, 0)) (H $$ (0, 0)))) i 0 K_init)"
have "Matrix.row ?lhs j $v ia = ?lhs $$ (j,ia)"
by (metis (no_types, lifting) Matrix.row_def ia index_mat_addrow(5) index_row(2) index_vec)
also have "... = (-?k) * ?L$$(0,ia) + ?L$$(j,ia)"
by (smt "2.prems"(1) "2.prems"(9) carrier_matD(1) ia index_mat_addrow(1,5) index_row(2)
insert_iff list.set(2) mult_carrier_mat rw that xa_P_init)
also have "... = ?rhs $$ (j,ia)" using "2"(10) "2"(4) i1 i3 ia j by auto
also have "... = Matrix.row ?rhs j $v ia" using 2 ia j by auto
finally show "Matrix.row ?lhs j $v ia = Matrix.row ?rhs j $v ia" .
qed (auto)
ultimately have "∀j∈set xs. Matrix.row K j =
Matrix.row (addrow (- (div_op (H $$ (j, 0)) (H $$ (0, 0)))) j 0 K_init) j" by auto
moreover have "Matrix.row K i = Matrix.row ?xb i"
by (rule reduce_column_aux_preserves[OF _ xa_P_init _ rw PK _ inv_xa_P_init zero_notin_xs
i3 i2],insert "2.prems", auto)
ultimately show ?case by auto
qed
corollary reduce_column_aux_index:
assumes H: "H ∈ carrier_mat m n"
and P_init: "P_init ∈ carrier_mat m m"
and K_init: "K_init ∈ carrier_mat m n"
and P_init_H_K_init: "P_init * H = K_init"
and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)"
and m: "0 < m"
and inv_P: "invertible_mat P_init"
and xs: "0 ∉ set xs"
and "∀x∈set xs. x<m"
and "distinct xs"
and "i∈set xs"
shows "Matrix.row K i =
Matrix.row (addrow (-(div_op (H $$ (i, 0)) (H $$ (0, 0)))) i 0 K_init) i"
using reduce_column_aux_index' assms by simp
corollary reduce_column_aux_works:
assumes H: "H ∈ carrier_mat m n"
and PK_H: "(P,K) = reduce_column_aux div_op xs H (1⇩m (dim_row H), H)"
and m: "0 < m"
and xs: "0 ∉ set xs"
and xm: "∀x ∈ set xs. x<m"
and d_xs: "distinct xs"
and i: "i ∈ set xs"
and dvd: "H $$ (0, 0) dvd H $$ (i, 0)"
and j0: "∀j∈{1..<n}. H$$(0,j) = 0"
and j1n: "j∈{1..<n}"
and n: "0<n"
and id: "is_div_op div_op"
shows "K $$ (i,0) = 0" and "K$$(i,j) = H $$ (i,j)"
proof -
let ?k = "div_op (H $$ (i, 0)) (H $$ (0, 0))"
let ?L = "addrow (-?k) i 0 H"
have kH00_eq_Hi0: "?k * H $$ (0, 0) = H $$ (i, 0)"
using id dvd unfolding is_div_op_def by simp
have *: "Matrix.row K i = Matrix.row ?L i"
by (rule reduce_column_aux_index[OF H _ _ _ PK_H], insert assms, auto)
also have " ... $v 0 = ?L $$ (i,0)" by (rule index_row, insert xm i H n, auto)
also have "... = (- ?k) * H$$(0,0) + H$$(i,0)" by (rule index_mat_addrow, insert i xm H n, auto)
also have "... = 0" using kH00_eq_Hi0 by auto
finally show "K $$ (i, 0) = 0"
by (metis H Matrix.row_def * n carrier_matD(2) dim_vec index_mat_addrow(5) index_vec)
have "Matrix.row ?L i $v j = ?L $$ (i,j)" by (rule index_row, insert xm i H n j1n, auto)
also have "... = (- ?k) * H$$(0,j) + H$$(i,j)" by (rule index_mat_addrow, insert xm i H j1n, auto)
also have "... = H$$(i,j)" using j1n j0 by auto
finally show "K$$(i,j) = H $$ (i,j)" by (metis H * Matrix.row_def atLeastLessThan_iff
carrier_matD(2) dim_vec index_mat_addrow(5) index_vec j1n)
qed
lemma reduce_column:
assumes H: "H ∈ carrier_mat m n"
and PK_H: "(P,K) = reduce_column div_op H"
and m: "0 < m"
shows "P ∈ carrier_mat m m ∧ K ∈ carrier_mat m n ∧ P * H = K ∧ invertible_mat P"
by (rule reduce_column_aux[OF _ _ _ _ PK_H[unfolded reduce_column_def]], insert assms, auto)
lemma reduce_column_preserves:
assumes H: "H ∈ carrier_mat m n"
and PK_H: "(P,K) = reduce_column div_op H"
and m: "0 < m"
and "i∈{0,1}"
and "i<m"
shows "Matrix.row K i = Matrix.row H i"
by (rule reduce_column_aux_preserves[OF _ _ _ _ PK_H[unfolded reduce_column_def]],
insert assms, auto)
lemma reduce_column_preserves2:
assumes H: "H ∈ carrier_mat m n"
and PK_H: "(P,K) = reduce_column div_op H"
and m: "0 < m" and i: "i∈{0,1}" and im: "i<m" and j: "j<n"
shows "K $$ (i,j) = H $$ (i,j)"
using reduce_column_preserves[OF H PK_H m i im]
by (metis H Matrix.row_def j carrier_matD(2) dim_vec index_vec)
corollary reduce_column_works:
assumes H: "H ∈ carrier_mat m n"
and PK_H: "(P,K) = reduce_column div_op H"
and m: "0 < m"
and dvd: "H $$ (0, 0) dvd H $$ (i, 0)"
and j0: "∀j∈{1..<n}. H $$ (0, j) = 0"
and j1n: "j∈{1..<n}"
and n: "0<n"
and "i∈{2..<m}"
and id: "is_div_op div_op"
shows "K $$ (i,0) = 0" and "K$$(i,j) = H $$ (i,j)"
by (rule reduce_column_aux_works[OF H PK_H[unfolded reduce_column_def]], insert assms, auto)+
end
subsection ‹The implementation›
text ‹We define a locale where we implement the algorithm. It has three fixed operations:
\begin{enumerate}
\item an operation to transform any $1 \times 2$ matrix into its Smith normal form
\item an operation to transform any $2 \times 2$ matrix into its Smith normal form
\item an operation that provides a witness for division (this operation always exists over a
commutative ring with unit, but maybe we cannot provide a computable algorithm).
\end{enumerate}
Since we are working in a commutative ring, we can easily get an operation for $2 \times 1$ matrices
via the $1 \times 2$ operation.
›
locale Smith_Impl =
fixes Smith_1x2 :: "('a::comm_ring_1) mat ⇒ ('a mat × 'a mat)"
and Smith_2x2 :: "'a mat ⇒ ('a mat × 'a mat × 'a mat)"
and div_op :: "'a⇒'a⇒'a"
assumes SNF_1x2_works: "∀(A::'a mat) ∈ carrier_mat 1 2. is_SNF A (1⇩m 1, (Smith_1x2 A))"
and SNF_2x2_works: "∀(A::'a mat) ∈ carrier_mat 2 2. is_SNF A (Smith_2x2 A)"
and id: "is_div_op div_op"
begin
text ‹From a $2 \times 2$ matrix (the $B$), we construct the identity matrix of size $n$ with
the elements of $B$ placed to modify the first element of a matrix and the element in position
$(k,k)$›
definition "make_mat n k (B::'a mat) = (Matrix.mat n n (λ(i,j). if i = 0 ∧ j = 0 then B$$(0,0) else
if i = 0 ∧ j = k then B$$(0,1) else if i=k ∧ j = 0
then B$$(1,0) else if i=k ∧ j=k then B$$(1,1)
else if i=j then 1 else 0))"
lemma make_mat_carrier[simp]:
shows "make_mat n k B ∈ carrier_mat n n"
unfolding make_mat_def by auto
lemma upper_triangular_mat_delete_make_mat:
shows "upper_triangular (mat_delete (make_mat n k B) 0 0)"
proof -
{ let ?M = "make_mat n k B"
fix i j
assume "i < dim_row ?M - Suc 0" and ji: "j < i"
hence i_n1: "i < n - 1" by (simp add: make_mat_def)
hence Suc_i: "Suc i < n" by linarith
hence Suc_j: "Suc j < n" using ji by auto
have i1: "insert_index 0 i = Suc i" by (rule insert_index, auto)
have j1: "insert_index 0 j = Suc j" by (rule insert_index, auto)
have "mat_delete ?M 0 0 $$ (i, j) = ?M $$ (insert_index 0 i, insert_index 0 j)"
by (rule mat_delete_index[symmetric, OF _ _ _ i_n1], insert Suc_i Suc_j, auto)
also have "... = ?M $$ (Suc i, Suc j)" unfolding i1 j1 by simp
also have "... = 0" unfolding make_mat_def unfolding index_mat[OF Suc_i Suc_j] using ji by auto
finally have "mat_delete ?M 0 0 $$ (i, j) = 0" .
}
thus ?thesis unfolding upper_triangular_def by auto
qed
lemma upper_triangular_mat_delete_make_mat2:
assumes kn: "k<n"
shows "upper_triangular (mat_delete (mat_delete (make_mat n k B) 0 k) (k - 1) 0)"
proof -
{ let ?M = "local.make_mat n k B"
let ?MD = "mat_delete ?M 0 k"
fix i j assume i: "i < dim_row ?M - 2" and ji: "j < i"
have insert_in: "insert_index 0 i < n" and insert_Sucin: "insert_index 0 (Suc i) < n"
using i make_mat_def by auto
have insert_k_Sucj: "insert_index k (Suc j) < n"
using insert_in insert_index_def ji by auto
have insert_j: "insert_index 0 j = Suc j" by simp
have "mat_delete ?MD (k - 1) 0 $$ (i, j) = ?MD $$ (insert_index (k-1) i, insert_index 0 j)"
proof (rule mat_delete_index[symmetric])
show "i < n-2" using i by (simp add: make_mat_def)
thus "?MD ∈ carrier_mat (Suc (n - 2)) (Suc (n - 2))"
by (metis Suc_diff_Suc card_num_simps(30) make_mat_carrier mat_delete_carrier
nat_diff_split_asm not_less0 not_less_eq numerals(2))
show "k - 1 < Suc (n - 2)" using kn by auto
show "0 < Suc (n - 2)" by blast
show "j < n - 2" using ji i by (simp add: make_mat_def)
qed
also have "... = ?MD $$ (insert_index (k-1) i, Suc j)" unfolding insert_j by auto
also have "... = 0"
proof (cases "i < (k-1)")
case True
hence "insert_index (k-1) i = i" by auto
hence "?MD $$ (insert_index (k-1) i, Suc j) = ?MD $$ (i, Suc j)" by auto
also have "... = ?M $$ (insert_index 0 i, insert_index k (Suc j))"
proof (rule mat_delete_index[symmetric])
show "?M ∈ carrier_mat (Suc (n-1)) (Suc (n-1))" using assms by auto
show "0 < Suc (n - 1)"
by blast
show "k < Suc (n - 1)"using kn by simp
show "i < n - 1" using i using True assms by linarith
thus "Suc j < n - 1" using ji less_trans_Suc by blast
qed
also have "... = 0" unfolding make_mat_def index_mat[OF insert_in insert_k_Sucj]
using True ji by auto
finally show ?thesis .
next
case False
hence "insert_index (k-1) i = Suc i" by auto
hence "?MD $$ (insert_index (k-1) i, Suc j) = ?MD $$ (Suc i, Suc j)" by auto
also have "... = ?M $$ (insert_index 0 (Suc i), insert_index k (Suc j))"
proof (rule mat_delete_index[symmetric])
show "?M ∈ carrier_mat (Suc (n-1)) (Suc (n-1))" using assms by auto
thus "Suc i < n - 1" using i using False assms
by (metis One_nat_def Suc_diff_Suc carrier_matD(1) diff_Suc_1 diff_Suc_eq_diff_pred
diff_is_0_eq' linorder_not_less nat.distinct(1) numeral_2_eq_2)
show "0 < Suc (n - 1)"
by blast
show "k < Suc (n - 1)"using kn by simp
show "Suc j < n - 1" using ji less_trans_Suc
using ‹Suc i < n - 1› by linarith
qed
also have "... = 0" unfolding make_mat_def index_mat[OF insert_Sucin insert_k_Sucj]
using False ji by (auto, smt insert_index_def less_SucI nat.inject nat_neq_iff)
finally show ?thesis .
qed
finally have "mat_delete ?MD (k - 1) 0 $$ (i, j) = 0" .
}
thus ?thesis unfolding upper_triangular_def by auto
qed
corollary det_mat_delete_make_mat:
assumes kn: "k<n"
shows "Determinant.det (mat_delete (mat_delete (make_mat n k B) 0 k) (k - 1) 0) = 1"
proof -
let ?M = "make_mat n k B"
let ?MD = "mat_delete ?M 0 k"
let ?MDMD = "mat_delete ?MD (k - 1) 0"
have eq1: "?MDMD $$ (i,i) = 1" if i: "i<n-2" for i
proof -
have i1: "insert_index 0 (insert_index (k-1) i) < n" using i insert_index_def by auto
have i2: "insert_index k (insert_index 0 i) < n" using i insert_index_def by auto
have "?MDMD $$ (i, i) = ?MD $$ (insert_index (k-1) i, insert_index 0 i)"
proof (rule mat_delete_index[symmetric, OF _ _ _ i i])
show "mat_delete (local.make_mat n k B) 0 k ∈ carrier_mat (Suc (n-2)) (Suc (n-2))"
by (metis (mono_tags, hide_lams) Suc_diff_Suc card_num_simps(30) i make_mat_carrier
mat_delete_carrier nat_diff_split_asm not_less0 not_less_eq numerals(2))
show "k - 1 < Suc (n - 2)" using kn by auto
show "0 < Suc (n - 2)" using kn by auto
qed
also have "... = ?M $$ (insert_index 0 (insert_index (k-1) i), insert_index k (insert_index 0 i))"
proof (rule mat_delete_index[symmetric])
show "make_mat n k B ∈ carrier_mat (Suc (n-1)) (Suc (n-1))" using i by auto
show "insert_index (k - 1) i < n - 1" using kn i
by (metis diff_Suc_eq_diff_pred diff_commute insert_index_def nat_neq_iff not_less0
numeral_2_eq_2 zero_less_diff)
show "insert_index 0 i < n - 1" using i by auto
qed (insert kn, auto)
also have "... = 1" unfolding make_mat_def index_mat[OF i1 i2]
by (auto, metis One_nat_def diff_Suc_1 insert_index_exclude)
(metis One_nat_def diff_Suc_eq_diff_pred insert_index_def zero_less_diff)+
finally show ?thesis .
qed
have "Determinant.det ?MDMD = prod_list (diag_mat ?MDMD)"
by (meson assms det_upper_triangular make_mat_carrier mat_delete_carrier
upper_triangular_mat_delete_make_mat2)
also have "... = 1"
proof (rule prod_list_neutral)
fix x assume x: "x ∈ set (diag_mat ?MDMD)"
from this obtain i where index: "x = ?MDMD $$ (i,i)" and i: "i<dim_row ?MDMD"
unfolding diag_mat_def by auto
have "?MDMD $$ (i,i) = 1" by (rule eq1, insert i, auto simp add: make_mat_def)
thus "x=1" using index by blast
qed
finally show ?thesis .
qed
lemma swaprows_make_mat:
assumes B: "B ∈ carrier_mat 2 2" and k0: "k≠0" and k: "k<n"
shows "swaprows k 0 (make_mat n k B) = make_mat n k (swaprows 1 0 B)" (is "?lhs = ?rhs")
proof (cases "n=0")
case True
then show ?thesis
using make_mat_def by auto
next
case False
show ?thesis
proof (rule eq_matI)
show "dim_row ?lhs = dim_row ?rhs" and "dim_col ?lhs = dim_col ?rhs"
by (simp add: make_mat_def)+
next
let ?M="(make_mat n k B)"
fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs"
hence i2: "i < dim_row ?lhs" and j2: "j < dim_col ?lhs" by (auto simp add: make_mat_def)
then have i3: "i < dim_row ?M" and j3: "j < dim_col ?M" by auto
then have i4: "i<n" and j4: "j<n" by (metis carrier_matD(1,2) make_mat_carrier)+
have lhs: "?lhs $$ (i,j) =
(if k = i then ?M $$ (0, j) else if 0 = i then ?M $$ (k, j) else ?M $$ (i, j))"
by (rule index_mat_swaprows, insert i3 j3, auto)
also have "... = ?rhs $$ (i,j)" using B i4 j4 False k0 k
unfolding make_mat_def index_mat[OF i4 j4] by auto
finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .
qed
qed
lemma cofactor_make_mat_00:
assumes k: "k<n" and k0: "k≠0"
shows "cofactor (make_mat n k B) 0 0 = B $$ (1,1)"
proof -
let ?M = "make_mat n k B"
let ?MD = "mat_delete ?M 0 0"
have MD_rows: "dim_row ?MD = n-1" by (simp add: make_mat_def)
have 1: "?MD $$ (i, i) = 1" if i: "i < n - 1" and ik: "Suc i ≠ k" for i
proof -
have Suc_i: "Suc i < n" using i by linarith
have "?MD $$ (i, i) = ?M $$ (insert_index 0 i, insert_index 0 i)"
by (rule mat_delete_index[symmetric, OF _ _ _ i], insert Suc_i, auto)
also have "... = ?M $$ (Suc i, Suc i)" by simp
also have "... = 1" unfolding make_mat_def index_mat[OF Suc_i Suc_i] using ik by auto
finally show ?thesis .
qed
have 2: "?MD $$ (i, i) = B$$(1,1)" if i: "i < n - 1" and ik: "Suc i = k" for i
proof -
have Suc_i: "Suc i < n" using i by linarith
have "?MD $$ (i, i) = ?M $$ (insert_index 0 i, insert_index 0 i)"
by (rule mat_delete_index[symmetric, OF _ _ _ i], insert Suc_i, auto)
also have "... = ?M $$ (Suc i, Suc i)" by simp
also have "... = B$$(1,1)" unfolding make_mat_def index_mat[OF Suc_i Suc_i] using ik by auto
finally show ?thesis .
qed
have set_rw: "insert (k-1) ({0..<dim_row ?MD}-{k-1}) = {0..<dim_row ?MD}"
using k k0 MD_rows by auto
have up: "upper_triangular ?MD" by (rule upper_triangular_mat_delete_make_mat)
have "Determinant.cofactor (local.make_mat n k B) 0 0
= Determinant.det (mat_delete (make_mat n k B) 0 0)" unfolding cofactor_def by auto
also have "... = prod_list (diag_mat ?MD)" using up
using det_upper_triangular make_mat_carrier mat_delete_carrier by blast
also have "... = (∏i = 0..<dim_row ?MD. ?MD $$ (i, i))" unfolding prod_list_diag_prod by simp
also have "... = (∏i ∈ insert (k-1) ({0..<dim_row ?MD}-{k-1}). ?MD $$ (i, i))"
using set_rw by simp
also have "... = ?MD $$ (k-1, k-1) * (∏i ∈ {0..<dim_row ?MD} - {k-1}. ?MD $$ (i, i))"
by (metis (no_types, lifting) Diff_iff finite_atLeastLessThan finite_insert prod.insert set_rw singletonI)
also have "... = B$$(1,1)"
by (smt "1" "2" DiffD1 DiffD2 Groups.mult_ac(2) MD_rows add_diff_cancel_left' add_diff_inverse_nat
k0 atLeastLessThan_iff class_cring.finprod_all1 insertI1 less_one more_arith_simps(5)
plus_1_eq_Suc set_rw)
finally show ?thesis .
qed
lemma cofactor_make_mat_0k:
assumes kn: "k<n" and k0: "k≠0" and n0: "1<n"
shows "cofactor (make_mat n k B) 0 k = - B $$ (1,0)"
proof -
let ?M = "make_mat n k B"
let ?MD = "mat_delete ?M 0 k"
have n0: "0<n-1" using n0 by auto
have MD_carrier: "?MD ∈ carrier_mat (n-1) (n-1)"
using make_mat_carrier mat_delete_carrier by blast
have MD_k1: "?MD $$ (k-1, 0) = B $$ (1,0)"
proof -
have n0': "0 < n" using n0 by auto
have insert_i: "insert_index 0 (k-1) = k" using k0 by auto
have insert_k: "insert_index k 0 = 0" using k0 by auto
have "?MD $$ (k-1, 0) = ?M $$ (insert_index 0 (k-1), insert_index k 0)"
by (rule mat_delete_index[symmetric, OF _ _ _ _ n0], insert k0 kn, auto)
also have "... = ?M $$ (k, 0)" unfolding insert_i insert_k by simp
also have "... = B $$ (1,0)" using k0 unfolding make_mat_def index_mat[OF kn n0'] by auto
finally show ?thesis .
qed
have MD0: "?MD $$ (i, 0) = 0" if i: "i<n-1" and ik: "Suc i≠k" for i
proof -
have i2: "Suc i < n" using i by auto
have n0': "0<n" using n0 by auto
have insert_i: "insert_index 0 i = Suc i" by simp
have insert_k: "insert_index k 0 = 0" using k0 by auto
have "?MD $$ (i, 0) = ?M $$ (insert_index 0 i, insert_index k 0)"
by (rule mat_delete_index[symmetric, OF _ _ _ i], insert i n0 kn, auto)
also have "... = ?M $$ (Suc i, 0)" unfolding insert_i insert_k by simp
also have "... = 0" using ik unfolding make_mat_def index_mat[OF i2 n0'] by auto
finally show ?thesis .
qed
have det_cofactor: "Determinant.cofactor ?MD (k-1) 0 = (-1) ^ (k - 1)"
unfolding cofactor_def using det_mat_delete_make_mat[OF kn] by auto
have sum0: "(∑i∈{0..<n - 1}-{k-1}. ?MD $$ (i, 0) * Determinant.cofactor ?MD i 0) = 0"
by (rule sum.neutral, insert MD0, fastforce)
have "Determinant.det ?MD = (∑i<n - 1. ?MD $$ (i, 0) * Determinant.cofactor ?MD i 0)"
by (rule laplace_expansion_column[OF MD_carrier n0])
also have "... = ?MD $$ (k-1, 0) * Determinant.cofactor ?MD (k-1) 0
+ (∑i∈{0..<n - 1}-{k-1}. ?MD $$ (i, 0) * Determinant.cofactor ?MD i 0)"
by (metis (no_types, lifting) Suc_less_eq add_diff_inverse_nat atLeast0LessThan finite_atLeastLessThan
k0 kn lessThan_iff less_one n0 nat_diff_split_asm plus_1_eq_Suc rel_simps(70) sum.remove)
also have "... = ?MD $$ (k-1, 0) * Determinant.cofactor ?MD (k-1) 0" unfolding sum0 by simp
also have "... = ?MD $$ (k-1, 0) * (-1) ^ (k - 1)" unfolding det_cofactor by auto
also have "... = (-1) ^ (k - 1) * B $$ (1,0)" using MD_k1 by auto
finally show ?thesis unfolding cofactor_def
by (metis (no_types, lifting) arithmetic_simps(49) k0 left_minus_one_mult_self
more_arith_simps(11) mult_minus1 power_eq_if)
qed
lemma invertible_make_mat:
assumes inv_B: "invertible_mat B" and B: "B ∈ carrier_mat 2 2"
and kn: "k<n" and k0: "k≠0"
shows "invertible_mat (make_mat n k B)"
proof -
let ?M = "(make_mat n k B)"
have M_carrier: "?M ∈ carrier_mat n n" by auto
show ?thesis
proof (cases "n=0")
case True
thus ?thesis using M_carrier using invertible_mat_zero by blast
next
case False note n_not_0 = False
show ?thesis
proof (cases "n=1")
case True
then show ?thesis using M_carrier using invertible_mat_zero assms by auto
next
case False
hence n: "0<n" using n_not_0 by auto
hence n1: "1<n" using False n_not_0 by auto
have M00: "?M $$ (0,0) = B $$ (0,0)" by (simp add: make_mat_def n)
have M0k: "?M $$ (0,k) = B $$ (0,1)" by (simp add: k0 kn make_mat_def n)
have sum0: "(∑j∈({0..<n}-{0} - {k}). ?M $$ (0, j) * Determinant.cofactor ?M 0 j) = 0"
proof (rule sum.neutral, rule ballI)
fix x assume x: "x ∈ {0..<n} - {0} - {k}"
have "make_mat n k B $$ (0,x) = 0" unfolding make_mat_def using x by auto
thus "local.make_mat n k B $$ (0, x) * Determinant.cofactor (local.make_mat n k B) 0 x = 0"
by simp
qed
have cofactor_M_00: "Determinant.cofactor ?M 0 0 = B$$(1,1)"
by (rule cofactor_make_mat_00[OF kn k0])
have cofactor_M_0k: "Determinant.cofactor ?M 0 k = - B $$ (1,0)"
by (rule cofactor_make_mat_0k[OF kn k0 n1])
have "Determinant.det ?M = (∑j<n. ?M $$ (0, j) * Determinant.cofactor ?M 0 j)"
using laplace_expansion_row[OF M_carrier n] by auto
also have "... = (∑j∈{0..<n}. ?M $$ (0, j) * Determinant.cofactor ?M 0 j)"
by (rule sum.cong, auto)
also have "... = ?M $$ (0, 0) * Determinant.cofactor ?M 0 0
+ ?M $$ (0, k) * Determinant.cofactor ?M 0 k
+ (∑j∈({0..<n}-{0} - {k}). ?M $$ (0, j) * Determinant.cofactor ?M 0 j)"
by (metis (no_types, lifting) add_cancel_right_right kn k0 atLeast0LessThan
atLeast1_lessThan_eq_remove0 finite_atLeastLessThan insert_Diff_single insert_iff
lessThan_iff n sum.atLeast_Suc_lessThan sum.remove sum0)
also have "... = ?M $$ (0, 0) * Determinant.cofactor ?M 0 0
+ ?M $$ (0, k) * Determinant.cofactor ?M 0 k" using sum0 by auto
also have "... = ?M $$ (0, 0) * B $$ (1,1) - ?M $$ (0, k)* B $$ (1,0)"
unfolding cofactor_M_00 cofactor_M_0k by auto
also have "... = B $$ (0, 0) * B $$ (1,1) - B $$ (0, 1)* B $$ (1,0)"
unfolding M00 M0k by auto
also have "... = Determinant.det B" unfolding det_2[OF B] by auto
finally have "Determinant.det ?M = Determinant.det B" .
thus ?thesis unfolding cofactor_def
using invertible_iff_is_unit_JNF by (metis B M_carrier inv_B)
qed
qed
qed
lemma make_mat_index:
assumes i: "i<n" and j: "j<n"
shows "make_mat n k B $$ (i,j) = (if i = 0 ∧ j = 0 then B$$(0,0) else
if i = 0 ∧ j = k then B$$(0,1) else if i=k ∧ j = 0
then B$$(1,0) else if i=k ∧ j=k then B$$(1,1)
else if i=j then 1 else 0)"
unfolding make_mat_def index_mat[OF i j] by simp
lemma make_mat_works:
assumes A: "A∈carrier_mat m n" and Suc_i_less_n: "Suc i < n"
and Q_step_def: "Q_step = (make_mat n (Suc i) (snd (Smith_1x2
(Matrix.mat 1 2 (λ(a,b). if b = 0 then A $$ (0,0) else A $$(0,Suc i))))))"
shows "A $$ (0,0) * Q_step $$ (0,(Suc i)) + A $$ (0, Suc i) * Q_step $$ (Suc i, Suc i) = 0"
proof -
have n0: "0<n" using Suc_i_less_n by simp
let ?A ="(Matrix.mat 1 2 (λ(a, b). if b = 0 then A $$ (0, 0) else A $$ (0, Suc i)))"
let ?S = "fst (Smith_1x2 ?A)"
let ?Q = "snd (Smith_1x2 ?A)"
have 1: "(make_mat n (Suc i) ?Q) $$ (0,Suc i) = ?Q $$ (0,1)"
unfolding make_mat_index[OF n0 Suc_i_less_n] by auto
have 2: "(make_mat n (Suc i) ?Q) $$ (Suc i, Suc i) = ?Q $$ (1,1)"
unfolding make_mat_index[OF Suc_i_less_n Suc_i_less_n] by auto
have is_SNF_A': "is_SNF ?A (1⇩m 1, Smith_1x2 ?A)" using SNF_1x2_works by auto
have SNF_S: "Smith_normal_form_mat ?S" and S: "?S = 1⇩m 1 * ?A * ?Q"
and Q: "?Q ∈ carrier_mat 2 2"
using is_SNF_A' unfolding is_SNF_def by auto
have "?S $$(0,1) = (?A * ?Q) $$(0,1)" unfolding S by auto
also have "... = Matrix.row ?A 0 ∙ col ?Q 1" by (rule index_mult_mat, insert Q, auto)
also have "... = (∑ia = 0..<dim_vec (col ?Q 1). Matrix.row ?A 0 $v ia * col ?Q 1 $v ia)"
unfolding scalar_prod_def by auto
also have "... = (∑ia ∈ {0,1}. Matrix.row ?A 0 $v ia * col ?Q 1 $v ia)"
by (rule sum.cong, insert Q, auto)
also have "... = Matrix.row ?A 0 $v 0 * col ?Q 1 $v 0 + Matrix.row ?A 0 $v 1 * col ?Q 1 $v 1"
using sum_two_elements by auto
also have "... = A $$ (0,0) * ?Q $$ (0,1) + A $$ (0,Suc i) * ?Q $$ (1,1)"
by (smt One_nat_def Q carrier_matD(1) carrier_matD(2) dim_col_mat(1) dim_row_mat(1) index_col
index_mat(1) index_row(1) lessI numeral_2_eq_2 pos2 prod.simps(2) rel_simps(93))
finally have "?S $$(0,1) = A $$ (0,0) * ?Q $$ (0,1) + A $$ (0,Suc i) * ?Q $$ (1,1)" by simp
moreover have "?S $$(0,1) = 0" using SNF_S unfolding Smith_normal_form_mat_def isDiagonal_mat_def
by (metis (no_types, lifting) Q S card_num_simps(30) carrier_matD(2) index_mult_mat(2)
index_mult_mat(3) index_one_mat(2) lessI n_not_Suc_n numeral_2_eq_2)
ultimately show ?thesis using 1 2 unfolding Q_step_def by auto
qed
subsubsection ‹Case $1 \times n$›
fun Smith_1xn_aux :: "nat ⇒ 'a mat ⇒ ('a mat × 'a mat) ⇒ ('a mat × 'a mat)"
where
"Smith_1xn_aux 0 A (S,Q) = (S,Q)" |
"Smith_1xn_aux (Suc i) A (S,Q) = (let
A_step_1x2 = (Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)));
(S_step_1x2, Q_step_1x2) = Smith_1x2 A_step_1x2;
Q_step = make_mat (dim_col A) (Suc i) Q_step_1x2;
S' = S * Q_step
in Smith_1xn_aux i A (S',Q*Q_step))"
definition "Smith_1xn A = (if dim_col A = 0 then (A,1⇩m (dim_col A))
else Smith_1xn_aux (dim_col A - 1) A (A,1⇩m (dim_col A)))"
lemma Smith_1xn_aux_Q_carrier:
assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))"
assumes A: "A ∈ carrier_mat 1 n" and Q: "Q ∈ carrier_mat n n"
shows "Q' ∈ carrier_mat n n"
using A r Q
proof (induct i A "(S,Q)" arbitrary: S Q rule: Smith_1xn_aux.induct)
case (1 A S Q)
then show ?case by auto
next
case (2 i A S Q)
note A = "2.prems"(1)
note S'Q' = "2.prems"(2)
note Q = "2.prems"(3)
let ?A_step_1x2 = "(Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)))"
let ?S_step_1x2 = "fst (Smith_1x2 ?A_step_1x2)"
let ?Q_step_1x2 = "snd (Smith_1x2 ?A_step_1x2)"
let ?Q_step = "make_mat (dim_col A) (Suc i) ?Q_step_1x2"
have rw: "A * (Q * ?Q_step) = A * Q * ?Q_step"
by (smt A Q assoc_mult_mat carrier_matD(2) make_mat_carrier)
have Smith_rw: "Smith_1xn_aux (Suc i) A (S, Q) = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)"
by (auto, metis (no_types, lifting) old.prod.exhaust snd_conv split_conv)
show ?case
proof (rule "2.hyps"[of ?A_step_1x2 "(?S_step_1x2, ?Q_step_1x2)" ?S_step_1x2 ?Q_step_1x2])
show "S * ?Q_step = S * ?Q_step" ..
show "A ∈ carrier_mat 1 n" using A by auto
show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto
show "Q * ?Q_step ∈ carrier_mat n n" using A Q by auto
qed (auto)
qed
lemma Smith_1xn_aux_invertible_Q:
assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))"
assumes A: "A ∈ carrier_mat 1 n" and Q: "Q ∈ carrier_mat n n"
and i: "i<n" and inv_Q: "invertible_mat Q"
shows "invertible_mat Q'"
using r A Q inv_Q i
proof (induct i A "(S,Q)" arbitrary: S Q rule: Smith_1xn_aux.induct)
case (1 A S Q)
then show ?case by auto
next
case (2 i A S Q)
let ?A_step_1x2 = "(Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)))"
let ?S_step_1x2 = "fst (Smith_1x2 ?A_step_1x2)"
let ?Q_step_1x2 = "snd (Smith_1x2 ?A_step_1x2)"
let ?Q_step = "make_mat (dim_col A) (Suc i) ?Q_step_1x2"
have Smith_rw: "Smith_1xn_aux (Suc i) A (S, Q) = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)"
by (auto, metis (no_types, lifting) old.prod.exhaust snd_conv split_conv)
have i_col: "Suc i < dim_col A"
using "2.prems" Suc_lessD by blast
have i_n: "i<n" by (simp add: "2.prems" Suc_lessD)
show ?case
proof (rule "2.hyps"[of ?A_step_1x2 "(?S_step_1x2, ?Q_step_1x2)" ?S_step_1x2 ?Q_step_1x2])
show "A ∈ carrier_mat 1 n" using "2.prems" by auto
show "Q * ?Q_step ∈ carrier_mat n n" using "2.prems" by auto
show "S * ?Q_step = S * ?Q_step" ..
show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto
show "invertible_mat (Q * ?Q_step)"
proof (rule invertible_mult_JNF)
show "Q ∈ carrier_mat n n" using "2.prems" by auto
show "?Q_step ∈ carrier_mat n n" using "2.prems" by auto
show "invertible_mat Q" using "2.prems" by auto
show "invertible_mat ?Q_step"
by (rule invertible_make_mat[OF _ _ i_col], insert SNF_1x2_works, unfold is_SNF_def, auto)
(metis (no_types, lifting) case_prodE mat_carrier snd_conv)+
qed
qed (auto simp add: i_n)
qed
lemma Smith_1xn_aux_S'_AQ':
assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))"
assumes A: "A ∈ carrier_mat 1 n" and S: "S ∈ carrier_mat 1 n" and Q: "Q ∈ carrier_mat n n"
and S_AQ: "S = A*Q" and i: "i<n"
shows "S' = A * Q'"
using A S r Q S_AQ
proof (induct i A "(S,Q)" arbitrary: S Q rule: Smith_1xn_aux.induct)
case (1 A S Q)
then show ?case by auto
next
case (2 i A S Q)
let ?A_step_1x2 = "(Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)))"
let ?S_step_1x2 = "fst (Smith_1x2 ?A_step_1x2)"
let ?Q_step_1x2 = "snd (Smith_1x2 ?A_step_1x2)"
let ?Q_step = "make_mat (dim_col A) (Suc i) ?Q_step_1x2"
have rw: "A * (Q * ?Q_step) = A * Q * ?Q_step"
by (smt "2.prems" assoc_mult_mat carrier_matD(2) make_mat_carrier)
have Smith_rw: "Smith_1xn_aux (Suc i) A (S, Q) = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)"
by (auto, metis (no_types, lifting) old.prod.exhaust snd_conv split_conv)
show ?case
proof (rule "2.hyps"[of ?A_step_1x2 "(?S_step_1x2, ?Q_step_1x2)" ?S_step_1x2 ?Q_step_1x2])
show "A ∈ carrier_mat 1 n" using "2.prems" by auto
show "Q * ?Q_step ∈ carrier_mat n n" using "2.prems" by auto
show "S * ?Q_step = S * ?Q_step" ..
show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto
show " S * ?Q_step = A * (Q * ?Q_step)" using "2.prems" rw by auto
show "S * ?Q_step ∈ carrier_mat 1 n"
using "2.prems" by (smt carrier_matD(2) make_mat_carrier mult_carrier_mat)
qed (auto)
qed
lemma Smith_1xn_aux_S'_works:
assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))"
assumes A: "A ∈ carrier_mat 1 n" and S: "S ∈ carrier_mat 1 n" and Q: "Q ∈ carrier_mat n n"
and S_AQ: "S = A*Q" and i: "i<n" and j0: "0<j" and jn: "j<n"
and all_j_zero: "∀j∈{i+1..<n}. S $$(0,j) = 0"
shows "S' $$ (0,j) = 0"
using A S r Q i S_AQ all_j_zero j0 jn
proof (induct i A "(S,Q)" arbitrary: S Q rule: Smith_1xn_aux.induct)
case (1 A S Q)
then show ?case using j0 jn by auto
next
case (2 i A S Q)
let ?A_step_1x2 = "(Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)))"
let ?S_step_1x2 = "fst (Smith_1x2 ?A_step_1x2)"
let ?Q_step_1x2 = "snd (Smith_1x2 ?A_step_1x2)"
let ?Q_step = "make_mat (dim_col A) (Suc i) ?Q_step_1x2"
have i_less_n: "i<n" by (simp add: "2"(6) Suc_lessD)
have rw: "A * (Q * ?Q_step) = A * Q * ?Q_step"
by (smt "2.prems" assoc_mult_mat carrier_matD(2) make_mat_carrier)
have Smith_rw: "Smith_1xn_aux (Suc i) A (S, Q) = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)"
by (auto, metis (no_types, lifting) old.prod.exhaust snd_conv split_conv)
have S'_AQ': "S' = A*Q'"
by (rule Smith_1xn_aux_S'_AQ', insert "2.prems", auto)
show ?case
proof (rule "2.hyps"[of ?A_step_1x2 "(?S_step_1x2, ?Q_step_1x2)" ?S_step_1x2 ?Q_step_1x2])
show "A ∈ carrier_mat 1 n" using "2.prems" by auto
show Q_Q_step_carrier: "Q * ?Q_step ∈ carrier_mat n n" using "2.prems" by auto
show "S * ?Q_step = S * ?Q_step" ..
show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto
show "S * ?Q_step = A * (Q * ?Q_step)" using "2.prems" rw by auto
show "S * ?Q_step ∈ carrier_mat 1 n"
using "2.prems" by (smt carrier_matD(2) make_mat_carrier mult_carrier_mat)
show "∀j∈{i + 1..<n}. (S * ?Q_step) $$ (0, j) = 0"
proof (rule ballI)
fix j assume j: "j∈{i + 1..<n}"
have "(S * ?Q_step) $$ (0, j) = Matrix.row S 0 ∙ col ?Q_step j"
by (rule index_mult_mat, insert j "2.prems", auto simp add: make_mat_def)
also have "... = 0"
proof (cases "j=Suc i")
case True
let ?f = "λx. Matrix.row S 0 $v x * col ?Q_step j $v x"
let ?set = "{0..<dim_vec (col ?Q_step j)}"
have set_rw: "?set = insert 0 (insert j (?set - {0} - {j}))"
using "2.prems" True make_mat_def by auto
have sum0: "(∑x ∈ ?set - {0} - {j}. ?f x) = 0"
proof (rule sum.neutral, rule ballI)
fix x assume x: "x ∈ ?set - {0} - {j}"
show "?f x = 0" using "2"(6) "2.prems" True make_mat_def x by auto
qed
have "Matrix.row S 0 ∙ col ?Q_step j = (∑x = 0..<dim_vec (col ?Q_step j). ?f x)"
unfolding scalar_prod_def by simp
also have "... = (∑x ∈ insert 0 (insert j (?set - {0} - {j})). ?f x)" using set_rw by auto
also have "... = ?f 0 + (∑x ∈ insert j (?set - {0} - {j}). ?f x)" by (simp add: True)
also have "... = ?f 0 + ?f j + (∑x ∈ ?set - {0} - {j}. ?f x)"
by (simp add: set_rw sum.insert_remove)
also have "... = ?f 0 + ?f j" using sum0 by auto
also have "... = S $$ (0,0) * ?Q_step $$ (0, Suc i) + S $$ (0,Suc i) * ?Q_step $$ (Suc i, Suc i)"
using "2.prems" True make_mat_def by auto
also have "... = 0" by (rule make_mat_works, insert "2.prems", auto)
finally show ?thesis .
next
case False note j_not_Suc_i = False
show ?thesis
unfolding scalar_prod_def
proof (rule sum.neutral, rule ballI)
fix x assume x: "x∈{0..<dim_vec (col ?Q_step j)}"
have xn: "x<n" using "2"(2) make_mat_def x by auto
have jn2: "j<dim_col A" using "2"(2) j by auto
have xn2: "x<dim_col A" using "2.prems"(1) xn by blast
have "Matrix.row S 0 $v x = S $$ (0,x)" using "2.prems" make_mat_def x by auto
moreover have "col ?Q_step j $v x = ?Q_step $$ (x,j)" using Q_Q_step_carrier j x by auto
ultimately have eq: "Matrix.row S 0 $v x * col ?Q_step j $v x = S $$ (0,x) * ?Q_step $$ (x,j)" by auto
have S_0x: "S $$ (0,x) = 0" if "Suc i + 1 ≤ x" using "2.prems" xn that by auto
moreover have "?Q_step $$ (x,j) = 0" if "x≤Suc i"
using that j j_not_Suc_i unfolding make_mat_def index_mat[OF xn2 jn2] by auto
ultimately show "Matrix.row S 0 $v x * (col ?Q_step j) $v x = 0" using eq by force
qed
qed
finally show "(S * ?Q_step) $$ (0, j) = 0" .
qed
qed (auto simp add: "2.prems" i_less_n)
qed
lemma Smith_1xn_works:
assumes A: "A ∈ carrier_mat 1 n"
and SQ: "(S,Q) = Smith_1xn A"
shows "is_SNF A (1⇩m 1, S,Q)"
proof (cases "n=0")
case True
thus ?thesis using assms
unfolding is_SNF_def
by (auto simp add: Smith_1xn_def)
next
case False
hence n0: "0<n" by auto
show ?thesis
proof (rule is_SNF_intro)
have SQ_eq: "(S,Q) = local.Smith_1xn_aux (dim_col A - 1) A (A,1⇩m (dim_col A))"
using SQ unfolding Smith_1xn_def by simp
have col: "dim_col A - 1 < dim_col A" using n0 A by auto
show "1⇩m 1 ∈ carrier_mat (dim_row A) (dim_row A)" using A by auto
show Q: "Q ∈ carrier_mat (dim_col A) (dim_col A)"
by (rule Smith_1xn_aux_Q_carrier[OF SQ_eq], insert A, auto)
show "invertible_mat (1⇩m 1)" by simp
show "invertible_mat Q" by (rule Smith_1xn_aux_invertible_Q[OF SQ_eq], insert A n0, auto)
have S_AQ: "S = A * Q"
by (rule Smith_1xn_aux_S'_AQ'[OF SQ_eq], insert A n0, auto)
thus "S = 1⇩m 1 * A * Q" using A by auto
have S: "S ∈ carrier_mat 1 n" using S_AQ A Q by auto
show "Smith_normal_form_mat S"
proof (rule Smith_normal_form_mat_intro)
show "∀a. a + 1 < min (dim_row S) (dim_col S) ⟶ S $$ (a, a) dvd S $$ (a + 1, a + 1)"
using S by auto
have "S $$ (0, j) = 0" if j0: "0 < j" and jn: "j < n" for j
by (rule Smith_1xn_aux_S'_works[OF SQ_eq], insert A n0 j0 jn, auto)
thus "isDiagonal_mat S" unfolding isDiagonal_mat_def using S by simp
qed
qed
qed
subsubsection ‹Case $n \times 1$›
definition "Smith_nx1 A =
(let (S,P) = (Smith_1xn_aux (dim_row A - 1) (transpose_mat A) (transpose_mat A,1⇩m (dim_row A)))
in (transpose_mat P, transpose_mat S))"
lemma Smith_nx1_works:
assumes A: "A ∈ carrier_mat n 1"
and SQ: "(P,S) = Smith_nx1 A"
shows "is_SNF A (P, S,1⇩m 1)"
proof (cases "n=0")
case True
thus ?thesis using assms
unfolding is_SNF_def
by (auto simp add: Smith_nx1_def)
next
case False
hence n0: "0<n" by auto
show ?thesis
proof (rule is_SNF_intro)
have SQ_eq: "(S⇧T, P⇧T) = (Smith_1xn_aux (dim_row A - 1) A⇧T (A⇧T,1⇩m (dim_row A)))"
using SQ[unfolded Smith_nx1_def] unfolding Let_def split_beta by auto
have "is_SNF (A⇧T) (1⇩m 1, S⇧T,P⇧T)"
by (rule Smith_1xn_works[unfolded Smith_1xn_def, OF _ _], insert SQ_eq A, auto)
have Pt: "P⇧T ∈ carrier_mat (dim_col (A⇧T)) (dim_col (A⇧T))"
by (rule Smith_1xn_aux_Q_carrier[OF SQ_eq], insert A n0, auto)
thus P: "P ∈ carrier_mat (dim_row A) (dim_row A)" by auto
show "1⇩m 1 ∈ carrier_mat (dim_col A) (dim_col A)" using A by simp
have "invertible_mat (P⇧T)"
by (rule Smith_1xn_aux_invertible_Q[OF SQ_eq], insert A n0, auto)
thus "invertible_mat P" by (metis det_transpose P Pt invertible_iff_is_unit_JNF)
show "invertible_mat (1⇩m 1)" by simp
have "S⇧T = A⇧T * P⇧T"
by (rule Smith_1xn_aux_S'_AQ'[OF SQ_eq], insert A n0, auto)
hence "S = P * A" by (metis A transpose_mult transpose_transpose P carrier_matD(1))
thus "S = P * A * 1⇩m 1" using P A by auto
hence S: "S ∈ carrier_mat n 1" using P A by auto
have "is_SNF (A⇧T) (1⇩m 1, S⇧T,P⇧T)"
by (rule Smith_1xn_works[unfolded Smith_1xn_def, OF _ _], insert SQ_eq A, auto)
hence "Smith_normal_form_mat (S⇧T)" unfolding is_SNF_def by auto
thus "Smith_normal_form_mat S" unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto
qed
qed
subsubsection ‹Case $2 \times n$›
function Smith_2xn :: "'a mat ⇒ ('a mat × 'a mat × 'a mat)"
where
"Smith_2xn A = (
if dim_col A = 0 then (1⇩m (dim_row A),A,1⇩m 0) else
if dim_col A = 1 then let (P,S) = Smith_nx1 A in (P,S, 1⇩m (dim_col A)) else
if dim_col A = 2 then Smith_2x2 A
else
let A1 = mat_of_cols (dim_row A) [col A 0];
A2 = mat_of_cols (dim_row A) [col A i. i ← [1..<dim_col A]];
(P1,D1,Q1) = Smith_2xn A2;
C = (P1*A1) @⇩c (P1*A2*Q1);
D = mat_of_cols (dim_row A) [col C 0, col C 1];
E = mat_of_cols (dim_row A) [col C i. i ← [2..<dim_col A]];
(P2,D2,Q2) = Smith_2x2 D;
H = (P2*D*Q2) @⇩c (P2 * E);
k = (div_op (H $$ (0,2)) (H $$ (0,0)));
H2 = addcol (-k) 2 0 H;
(_,_,_,H2_DR) = split_block H2 1 1;
(H_1xn,Q3) = Smith_1xn H2_DR;
S = four_block_mat (Matrix.mat 1 1 (λ(a,b). H$$(0,0))) (0⇩m 1 (dim_col A - 1)) (0⇩m 1 1) H_1xn;
Q1' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_col A - 1)) (0⇩m (dim_col A - 1) 1) Q1;
Q2' = four_block_mat Q2 (0⇩m 2 (dim_col A - 2)) (0⇩m (dim_col A - 2) 2) (1⇩m (dim_col A - 2));
Q_div_k = addrow_mat (dim_col A) (-k) 0 2;
Q3' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_col A - 1)) (0⇩m (dim_col A - 1) 1) Q3
in (P2 * P1,S,Q1' * Q2' * Q_div_k * Q3'))"
by pat_completeness auto
termination apply (relation "measure (λA. dim_col A)") by auto
lemma Smith_2xn_0:
assumes A: "A ∈ carrier_mat 2 0"
shows "is_SNF A (Smith_2xn A)"
proof -
have "Smith_2xn A = (1⇩m (dim_row A),A,1⇩m 0)"
using A by auto
moreover have "is_SNF A ..." by (rule is_SNF_intro, insert A, auto)
ultimately show ?thesis by simp
qed
lemma Smith_2xn_1:
assumes A: "A ∈ carrier_mat 2 1"
shows "is_SNF A (Smith_2xn A)"
proof -
obtain P S where PS: "Smith_nx1 A = (P,S)" using prod.exhaust by blast
have *: "is_SNF A (P, S,1⇩m 1)" by (rule Smith_nx1_works[OF A PS[symmetric]])
moreover have "Smith_2xn A = (P,S, 1⇩m (dim_col A))"
using A PS by auto
moreover have "is_SNF A ..." using * A by auto
ultimately show ?thesis by simp
qed
lemma Smith_2xn_2:
assumes A: "A ∈ carrier_mat 2 2"
shows "is_SNF A (Smith_2xn A)"
proof -
have "Smith_2xn A = Smith_2x2 A" using A by auto
from this show ?thesis using SNF_2x2_works using A by auto
qed
lemma is_SNF_Smith_2xn_n_ge_2:
assumes A: "A ∈ carrier_mat 2 n" and n: "n>2"
shows "is_SNF A (Smith_2xn A)"
using A n id
proof (induct A arbitrary: n rule: Smith_2xn.induct)
case (1 A)
note A = "1.prems"(1)
note n_ge_2 = "1.prems"(2)
have dim_col_A_g2: "dim_col A > 2" using n_ge_2 A by auto
define A1 where "A1 = mat_of_cols (dim_row A) [col A 0]"
define A2 where "A2 = mat_of_cols (dim_row A) [col A i. i ← [1..<dim_col A]]"
obtain P1 D1 Q1 where P1D1Q1: "(P1,D1,Q1) = Smith_2xn A2" by (metis prod_cases3)
define C where "C = (P1*A1) @⇩c (P1*A2*Q1)"
define D where "D = mat_of_cols (dim_row A) [col C 0, col C 1]"
define E where "E = mat_of_cols (dim_row A) [col C i. i ← [2..<dim_col A]]"
obtain P2 D2 Q2 where P2D2Q2: "(P2,D2,Q2) = Smith_2x2 D" by (metis prod_cases3)
define H where "H = (P2*D*Q2) @⇩c (P2 * E)"
define k where "k = div_op (H $$ (0,2)) (H $$ (0,0))"
define H2 where "H2 = addcol (-k) 2 0 H"
obtain H2_UL H2_UR H2_DL H2_DR
where split_H2: "(H2_UL, H2_UR, H2_DL, H2_DR) = (split_block H2 1 1)" by (metis prod_cases4)
obtain H_1xn Q3 where H_1xn_Q3: "(H_1xn,Q3) = Smith_1xn H2_DR" by (metis surj_pair)
define S where "S = four_block_mat (Matrix.mat 1 1 (λ(a,b). H$$(0,0))) (0⇩m 1 (dim_col A - 1)) (0⇩m 1 1) H_1xn"
define Q1' where "Q1' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_col A - 1)) (0⇩m (dim_col A - 1) 1) Q1"
define Q2' where "Q2' = four_block_mat Q2 (0⇩m 2 (dim_col A - 2)) (0⇩m (dim_col A - 2) 2) (1⇩m (dim_col A - 2))"
define Q_div_k where "Q_div_k = addrow_mat (dim_col A) (-k) 0 2"
define Q3' where "Q3' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_col A - 1)) (0⇩m (dim_col A - 1) 1) Q3"
have Smith_2xn_rw: "Smith_2xn A = (P2 * P1, S, Q1' * Q2' * Q_div_k * Q3')"
proof (rule prod3_intro)
have P1_def: "fst (Smith_2xn A2) = P1" and Q1_def: "snd (snd (Smith_2xn A2)) = Q1"
and P2_def: "fst (Smith_2x2 D) = P2" and Q2_def: "snd (snd (Smith_2x2 D)) = Q2"
and H_1xn_def: "fst (Smith_1xn H2_DR) = H_1xn" and Q3_def: "snd (Smith_1xn H2_DR) = Q3"
and H2_DR_def: "snd (snd (snd (split_block H2 1 1))) = H2_DR"
using P2D2Q2 P1D1Q1 H_1xn_Q3 split_H2 fstI sndI by metis+
note aux= P1_def Q1_def Q1'_def Q2'_def Q_div_k_def Q3'_def S_def A1_def[symmetric]
C_def[symmetric] P2_def Q2_def Q3_def D_def[symmetric] E_def[symmetric] H_def[symmetric]
k_def[symmetric] H2_def[symmetric] H2_DR_def H_1xn_def A2_def[symmetric]
show "fst (Smith_2xn A) = P2 * P1"
using dim_col_A_g2 unfolding Smith_2xn.simps[of A] Let_def split_beta
by (insert P1D1Q1 P2D2Q2 D_def C_def, unfold aux, auto simp del: Smith_2xn.simps)
show "fst (snd (Smith_2xn A)) = S"
using dim_col_A_g2 unfolding Smith_2xn.simps[of A] Let_def split_beta
by (insert P1D1Q1 P2D2Q2, unfold aux, auto simp del: Smith_2xn.simps)
show "snd (snd (Smith_2xn A)) = Q1' * Q2' * Q_div_k * Q3'"
using dim_col_A_g2 unfolding Smith_2xn.simps[of A] Let_def split_beta
by (insert P1D1Q1 P2D2Q2, unfold aux, auto simp del: Smith_2xn.simps)
qed
show ?case
proof (unfold Smith_2xn_rw, rule is_SNF_intro)
have is_SNF_A2: "is_SNF A2 (Smith_2xn A2)"
proof (cases "2<dim_col A2")
case True
show ?thesis
by (rule "1.hyps", insert True A dim_col_A_g2 id, auto simp add: A2_def)
next
case False
hence "dim_col A2 = 2" using n_ge_2 A unfolding A2_def by auto
hence A2: "A2∈carrier_mat 2 2" unfolding A2_def using A by auto
hence *: "Smith_2xn A2 = Smith_2x2 A2" by auto
show ?thesis unfolding * using SNF_2x2_works A2 by auto
qed
have A1[simp]: "A1 ∈ carrier_mat (dim_row A) 1" unfolding A1_def by auto
have A2[simp]: "A2 ∈ carrier_mat (dim_row A) (dim_col A - 1)" unfolding A2_def by auto
have P1[simp]: "P1 ∈ carrier_mat (dim_row A) (dim_row A)"
and inv_P1: "invertible_mat P1"
and Q1: "Q1 ∈ carrier_mat (dim_col A2) (dim_col A2)" and inv_Q1: "invertible_mat Q1"
and SNF_P1A2Q1: "Smith_normal_form_mat (P1*A2*Q1)"
using is_SNF_A2 P1D1Q1 A2 unfolding is_SNF_def by fastforce+
have D[simp]: "D ∈ carrier_mat 2 2" unfolding D_def
by (metis "1"(2) One_nat_def Suc_eq_plus1 carrier_matD(1) list.size(3)
list.size(4) mat_of_cols_carrier(1) numerals(2))
have is_SNF_D: "is_SNF D (Smith_2x2 D)" using SNF_2x2_works D by auto
hence P2[simp]: "P2 ∈ carrier_mat (dim_row A) (dim_row A)" and inv_P2: "invertible_mat P2"
and Q2[simp]: "Q2 ∈ carrier_mat (dim_col D) (dim_col D)" and inv_Q2: "invertible_mat Q2"
using P2D2Q2 D_def unfolding is_SNF_def by force+
show P2_P1: "P2 * P1 ∈ carrier_mat (dim_row A) (dim_row A)" by (rule mult_carrier_mat[OF P2 P1])
show "invertible_mat (P2 * P1)" by (rule invertible_mult_JNF[OF P2 P1 inv_P2 inv_P1])
have Q1': "Q1' ∈ carrier_mat (dim_col A) (dim_col A)" using Q1 unfolding Q1'_def
by (auto, smt A2 One_nat_def add_diff_inverse_nat carrier_matD(1) carrier_matD(2) carrier_matI
dim_col_A_g2 gr_implies_not0 index_mat_four_block(2) index_mat_four_block(3)
index_one_mat(2) index_one_mat(3) less_Suc0)
have Q2': "Q2' ∈ carrier_mat (dim_col A) (dim_col A)" using Q2 unfolding Q2'_def
by (smt D One_nat_def Suc_lessD add_diff_inverse_nat carrier_matD(1) carrier_matD(2)
carrier_matI dim_col_A_g2 gr_implies_not0 index_mat_four_block(2) index_mat_four_block(3)
index_one_mat(2) index_one_mat(3) less_2_cases numeral_2_eq_2 semiring_norm(138))
have H2[simp]: "H2 ∈ carrier_mat (dim_row A) (dim_col A)" using A P2 D unfolding H2_def H_def
by (smt E_def Q2 Q2' Q2'_def append_cols_def arithmetic_simps(50) carrier_matD(1) carrier_matD(2)
carrier_mat_triv index_mat_addcol(4) index_mat_addcol(5) index_mat_four_block(2)
index_mat_four_block(3) index_mult_mat(2) index_mult_mat(3) index_one_mat(2) index_zero_mat(2)
index_zero_mat(3) length_map length_upt mat_of_cols_carrier(3))
have H'[simp]: "H2_DR ∈ carrier_mat 1 (n - 1)"
by (rule split_block(4)[OF split_H2[symmetric]], insert H2 A n_ge_2, auto)
have is_SNF_H': "is_SNF H2_DR (1⇩m 1, H_1xn, Q3)"
by (rule Smith_1xn_works[OF H' H_1xn_Q3])
from this have Q3: "Q3 ∈ carrier_mat (dim_col H2_DR) (dim_col H2_DR)" and inv_Q3: "invertible_mat Q3"
unfolding is_SNF_def by auto
have Q3': "Q3' ∈ carrier_mat (dim_col A) (dim_col A)"
by (metis A A2 H' Q1 Q1' Q1'_def Q3 Q3'_def carrier_matD(1) carrier_matD(2) carrier_matI
index_mat_four_block(2) index_mat_four_block(3))
have Q_div_k[simp]: "Q_div_k ∈ carrier_mat (dim_col A) (dim_col A)" unfolding Q_div_k_def by auto
have inv_Q_div_k: "invertible_mat Q_div_k"
by (metis Q_div_k Q_div_k_def det_addrow_mat det_one invertible_iff_is_unit_JNF
invertible_mat_one nat.simps(3) numerals(2) one_carrier_mat)
show "Q1' * Q2' * Q_div_k * Q3' ∈ carrier_mat (dim_col A) (dim_col A)"
using Q1' Q2' Q_div_k Q3' by auto
have inv_Q1': "invertible_mat Q1'"
proof -
have "invertible_mat (four_block_mat (1⇩m 1) (0⇩m 1 (n - 1)) (0⇩m (n - 1) 1) Q1)"
by (rule invertible_mat_four_block_mat_lower_right, insert Q1 inv_Q1 A2 "1.prems", auto)
thus ?thesis unfolding Q1'_def using A by auto
qed
have inv_Q2': "invertible_mat Q2'"
by (unfold Q2'_def, rule invertible_mat_four_block_mat_lower_right_id,
insert Q2 n_ge_2 inv_Q2 A D, auto)
have inv_Q3': "invertible_mat Q3'"
proof -
have "invertible_mat (four_block_mat (1⇩m 1) (0⇩m 1 (n - 1)) (0⇩m (n - 1) 1) Q3)"
by (rule invertible_mat_four_block_mat_lower_right, insert Q3 H' inv_Q3 "1.prems", auto)
thus ?thesis unfolding Q3'_def using A by auto
qed
show "invertible_mat (Q1' * Q2' * Q_div_k * Q3')"
using inv_Q1' inv_Q2' inv_Q_div_k inv_Q3'
by (meson Q1' Q2' Q3' Q_div_k invertible_mult_JNF mult_carrier_mat)
have A_A1_A2: "A = A1 @⇩c A2" unfolding A1_def A2_def append_cols_def
proof (rule eq_matI, auto)
fix i assume i: "i < dim_row A" show 1: "A $$ (i, 0) = mat_of_cols (dim_row A) [col A 0] $$ (i, 0)"
by (metis dim_col_A_g2 gr_zeroI i index_col mat_of_cols_Cons_index_0 not_less0)
let ?xs = "(map (col A) [Suc 0..<dim_col A])"
fix j
assume j1: "j < Suc (dim_col A - Suc 0)"
and j2: "0 < j"
have "mat_of_cols (dim_row A) ?xs $$ (i, j - Suc 0) = ?xs ! (j - Suc 0) $v i"
by (rule mat_of_cols_index, insert j1 j2 i, auto)
also have "... = A $$ (i,j)" using dim_col_A_g2 i j1 j2 by auto
finally show "A $$ (i, j) = mat_of_cols (dim_row A) ?xs $$ (i, j - Suc 0)" ..
next
show "dim_col A = Suc (dim_col A - Suc 0)" using n_ge_2 A by auto
qed
have C_P1_A_Q1': "C = P1 * A * Q1'"
proof -
have aux: "P1 * (A1 @⇩c A2) = ((P1 * A1) @⇩c (P1 * A2))"
by (rule append_cols_mult_left, insert A1 A2 P1, auto)
have "P1 * A * Q1' = P1 * (A1 @⇩c A2) * Q1'" using A_A1_A2 by simp
also have "... = ((P1 * A1) @⇩c (P1 * A2)) * Q1'" unfolding aux ..
also have "... = (P1 * A1) @⇩c ((P1 * A2) * Q1)"
by (rule append_cols_mult_right_id, insert P1 A1 A2 Q1'_def Q1, auto)
finally show ?thesis unfolding C_def by auto
qed
have E_ij_0: "E $$ (i,j) = 0" if i: "i<dim_row E" and j: "j<dim_col E" and ij: "(i,j) ≠ (1,0)"
for i j
proof -
let ?ws = "(map (col C) [2..<dim_col A])"
have "E $$ (i,j) = ?ws ! j $v i "
by (unfold E_def, rule mat_of_cols_index, insert i j A E_def, auto)
also have "... = (col C (j+2)) $v i" using E_def j by auto
also have "... = C $$ (i,j+2)"
by (metis C_P1_A_Q1' P1 Q1' E_def carrier_matD(1) carrier_matD(2) index_col index_mult_mat(2)
index_mult_mat(3) length_map length_upt less_diff_conv mat_of_cols_carrier(2)
mat_of_cols_carrier(3) i j)
also have "... = (if j + 2 < dim_col (P1*A1) then (P1*A1) $$ (i, j + 2)
else (P1 * A2 * Q1) $$ (i, (j+2) - 1))"
unfolding C_def
by (rule append_cols_nth, insert i j P1 A1 A2 Q1 A, auto simp add: E_def)
also have "... = (P1 * A2 * Q1) $$ (i, j+1)"
by (metis A1 One_nat_def add.assoc add_diff_cancel_right' add_is_0 arith_special(3)
carrier_matD(2) index_mult_mat(3) less_Suc0 zero_neq_numeral)
also have "... = 0" using SNF_P1A2Q1 unfolding Smith_normal_form_mat_def isDiagonal_mat_def
by (metis (no_types, lifting) A A2 P1 Q1 Suc_diff_Suc Suc_mono E_def add_Suc_right
add_lessD1 arith_extra_simps(6) carrier_matD(1) carrier_matD(2) dim_col_A_g2
gr_implies_not0 index_mult_mat(2) index_mult_mat(3) length_map length_upt less_Suc_eq
mat_of_cols_carrier(2) mat_of_cols_carrier(3) numeral_2_eq_2 plus_1_eq_Suc i j ij)
finally show ?thesis .
qed
have C_D_E: "C = D @⇩c E"
proof (rule eq_matI)
have "C $$ (i, j) = mat_of_cols (dim_row A) [col C 0, col C 1] $$ (i, j)"
if i: "i < dim_row A" and j: "j < 2" for i j
proof -
let ?ws = "[col C 0, col C 1]"
have "mat_of_cols (dim_row A) [col C 0, col C 1] $$ (i, j) = ?ws ! j $v i"
by (rule mat_of_cols_index, insert i j, auto)
also have "... = C $$ (i, j)" using j index_col
by (auto, smt A C_P1_A_Q1' P1 Q1' Suc_lessD carrier_matD i index_col index_mult_mat(2,3)
less_2_cases n_ge_2 nth_Cons_0 nth_Cons_Suc numeral_2_eq_2)
finally show ?thesis by simp
qed
moreover have "C $$ (i, j) = mat_of_cols (dim_row A) (map (col C) [2..<dim_col A]) $$ (i, j - 2)"
if i: "i < dim_row A" and j1: "j < dim_col A" and j2: "j ≥ 2" for i j
proof -
let ?ws = "(map (col C) [2..<dim_col A])"
have "mat_of_cols (dim_row A) ?ws $$ (i, j - 2) = ?ws ! (j-2) $v i"
by (rule mat_of_cols_index, insert i j1 j2, auto)
also have "... = C $$ (i,j)"
by (metis C_P1_A_Q1' P1 Q1' add_diff_inverse_nat carrier_matD(1) carrier_matD(2) dim_col_A_g2
i index_col index_mult_mat(2) index_mult_mat(3) less_diff_iff less_imp_le_nat
linorder_not_less nth_map_upt j1 j2)
finally show ?thesis by auto
qed
ultimately show "⋀i j. i < dim_row (D @⇩c E) ⟹ j < dim_col (D @⇩c E) ⟹ C $$ (i, j) = (D @⇩c E) $$ (i, j)"
unfolding D_def E_def append_cols_def by (auto simp add: numerals)
show "dim_row C = dim_row (D @⇩c E)" using P1 A unfolding C_def D_def E_def append_cols_def by auto
show "dim_col C = dim_col (D @⇩c E)" using A1 Q1 A2 A n_ge_2
unfolding C_def D_def E_def append_cols_def by auto
qed
have E[simp]: "E∈carrier_mat 2 (n-2)" unfolding E_def using A by auto
have H[simp]: "H ∈ carrier_mat (dim_row A) (dim_col A)" unfolding H_def append_cols_def using A
by (smt E Groups.add_ac(1) One_nat_def P2_P1 Q2 Q2' Q2'_def carrier_matD index_mat_four_block
plus_1_eq_Suc index_mult_mat index_one_mat index_zero_mat numeral_2_eq_2 carrier_matI)
have H_P2_P1_A_Q1'_Q2': "H = P2 * P1 * A * Q1' * Q2'"
proof -
have aux: "(P2 * D @⇩c P2 * E) = P2 * (D @⇩c E)"
by (rule append_cols_mult_left[symmetric], insert D E P2 A, auto simp add: D_def E_def)
have "H = P2 * D * Q2 @⇩c P2 * E" using H_def by auto
also have "... = (P2 * D @⇩c P2 * E) * Q2'" by (rule append_cols_mult_right_id2[symmetric],
insert Q2 D Q2'_def, auto simp add: D_def E_def)
also have "... = (P2 * (D @⇩c E)) * Q2'" using aux by auto
also have "... = P2 * C * Q2'" unfolding C_D_E by auto
also have "... = P2 * P1 * A * Q1' * Q2'" unfolding C_P1_A_Q1'
by (smt P1 P2 Q1' P2_P1 assoc_mult_mat carrier_mat_triv index_mult_mat(2))
finally show ?thesis .
qed
have H2_H_Q_div_k: "H2 = H * Q_div_k" unfolding H2_def Q_div_k_def
by (metis H_P2_P1_A_Q1'_Q2' Q2' addcol_mat carrier_matD(2) dim_col_A_g2 gr_implies_not0
mat_carrier times_mat_def zero_order(5))
hence H2_P2_P1_A_Q1'_Q2'_Q_div_k: "H2 = P2 * P1 * A * Q1' * Q2' * Q_div_k"
unfolding H_P2_P1_A_Q1'_Q2' by simp
have H2_as_four_block_mat: "H2 = four_block_mat H2_UL H2_UR H2_DL H2_DR"
by (rule split_block[OF split_H2[symmetric], of _ "n-1"], insert H2 A n_ge_2, auto)
have H2_UL: "H2_UL ∈ carrier_mat 1 1"
by (rule split_block[OF split_H2[symmetric], of _ "n-1"], insert H2 A n_ge_2, auto)
have H2_UR: "H2_UR ∈ carrier_mat 1 (dim_col A - 1)"
by (rule split_block(2)[OF split_H2[symmetric]], insert H2 A n_ge_2, auto)
have H2_DL: "H2_DL ∈ carrier_mat 1 1"
by (rule split_block[OF split_H2[symmetric], of _ "n-1"], insert H2 A n_ge_2, auto)
have H2_DR: "H2_DR ∈ carrier_mat 1 (dim_col A - 1)"
by (rule split_block[OF split_H2[symmetric]], insert H2 A n_ge_2, auto)
have H2_UR_00: "H2_UR $$ (0,0) = 0"
proof -
have "H2_UR $$ (0,0) = H2 $$ (0,1)"
by (smt A H2_H_Q_div_k H2_UL H2_as_four_block_mat H2_def H_P2_P1_A_Q1'_Q2'
Num.numeral_nat(7) P2_P1 Q2' add_diff_cancel_left' carrier_matD dim_col_A_g2 index_mat_addcol
index_mat_four_block index_mult_mat less_trans_Suc plus_1_eq_Suc pos2 semiring_norm(138)
zero_less_one_class.zero_less_one)
also have "... = H $$ (0,1)"
unfolding H2_def by (rule index_mat_addcol, insert H A n_ge_2, auto)
also have "... = (P2 * D * Q2) $$ (0,1)"
by (smt C_D_E C_P1_A_Q1' D H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2' H_def Q1'
Q2 add_lessD1 append_cols_def carrier_matD(1) carrier_matD(2) dim_col_A_g2
index_mat_four_block index_mult_mat(2) index_mult_mat(3) lessI numerals(2) plus_1_eq_Suc zero_less_Suc)
also have "... = 0" using is_SNF_D P2D2Q2 D
unfolding is_SNF_def Smith_normal_form_mat_def isDiagonal_mat_def by auto
finally show "H2_UR $$ (0,0) = 0" .
qed
have H2_UR_0j: "H2_UR $$ (0,j) = 0" if j_ge_1: "j > 1" and j: "j<n-1" for j
proof -
have col_E_0: "col E (j - 1) = 0⇩v 2"
by (rule eq_vecI, unfold col_def, insert E E_ij_0 j j_ge_1 n_ge_2, auto)
(metis E Suc_diff_Suc Suc_lessD Suc_less_eq Suc_pred carrier_matD index_vec numerals(2), insert E, blast)
have "H2_UR $$ (0,j) = H2 $$ (0,j+1)"
by (metis (no_types, lifting) A H2_P2_P1_A_Q1'_Q2'_Q_div_k H2_UL H2_as_four_block_mat H2_def
H_P2_P1_A_Q1'_Q2' P2_P1 Q2' add_diff_cancel_right' carrier_matD index_mat_addcol(5)
index_mat_four_block index_mult_mat(2,3) less_diff_conv less_numeral_extra(1) not_add_less2 pos2 j)
also have "... = H $$ (0,j+1)" unfolding H2_def
by (metis A H2_P2_P1_A_Q1'_Q2'_Q_div_k H2_def H_P2_P1_A_Q1'_Q2' One_nat_def P2_P1 Q_div_k_def
add_right_cancel carrier_matD(1) carrier_matD(2) index_mat_addcol(3) index_mat_addcol(5)
index_mat_addrow_mat(3) index_mult_mat(2) index_mult_mat(3) less_diff_conv less_not_refl2
numerals(2) plus_1_eq_Suc pos2 j j_ge_1)
also have "... = (if j+1 < dim_col (P2 * D * Q2)
then (P2 * D * Q2) $$ (0, j+1) else (P2*E) $$ (0, (j+1) - 2))"
by (unfold H_def, rule append_cols_nth, insert E P2 A Q2 D j, auto simp add: E_def)
also have "... = (P2*E) $$ (0, j - 1)"
by (metis (no_types, lifting) D One_nat_def Q2 add_Suc_right add_lessD1 arithmetic_simps(50)
carrier_matD(2) diff_Suc_Suc index_mult_mat(3) not_less_eq numeral_2_eq_2 j_ge_1)
also have "... = Matrix.row P2 0 ∙ col E (j - 1)"
by (rule index_mult_mat, insert P2 j_ge_1 A j, auto simp add: E_def)
also have "... = 0" unfolding col_E_0 by (simp add: scalar_prod_def)
finally show ?thesis .
qed
have H00_dvd_D01: "H$$(0,0) dvd D$$(0,1)"
proof -
have "H$$(0,0) = (P2*D*Q2) $$ (0,0)" unfolding H_def using append_cols_nth D E
by (smt A C_D_E C_P1_A_Q1' D H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2'
One_nat_def P1 Q1' Q2 Suc_lessD append_cols_def carrier_matD dim_col_A_g2
index_mat_four_block index_mult_mat numerals(2) plus_1_eq_Suc zero_less_Suc)
also have "... dvd D$$(0,1)" by (rule S00_dvd_all_A[OF D _ _ inv_P2 inv_Q2],
insert is_SNF_D P2D2Q2 P2 Q2 D, unfold is_SNF_def, auto)
finally show ?thesis .
qed
have D01_dvd_H02: "D$$(0,1) dvd H$$(0,2)" and D01_dvd_H12: "D$$(0,1) dvd H$$(1,2)"
proof -
have "D$$(0,1) = C$$(0,1)" unfolding C_D_E
by (smt A C_D_E C_P1_A_Q1' D One_nat_def P1 Q1' append_cols_def carrier_matD(1) carrier_matD(2)
dim_col_A_g2 index_mat_four_block(1) index_mat_four_block(2) index_mat_four_block(3)
index_mult_mat(2) index_mult_mat(3) lessI less_trans_Suc numerals(2) pos2)
also have "... = (P1*A2*Q1) $$ (0,0)" using C_def
by (smt "1"(2) A1 A_A1_A2 P1 Q1 add_diff_cancel_left' append_cols_def card_num_simps(30)
carrier_matD dim_col_A_g2 index_mat_four_block index_mult_mat less_numeral_extra(4)
less_trans_Suc plus_1_eq_Suc pos2)
also have "... dvd (P1*A2*Q1) $$ (1,1)"
by (smt "1"(2) A2 One_nat_def P1 Q1 S00_dvd_all_A SNF_P1A2Q1 carrier_matD(1) carrier_matD(2) dim_col_A_g2
dvd_elements_mult_matrix_left_right inv_P1 inv_Q1 lessI less_diff_conv numeral_2_eq_2 plus_1_eq_Suc)
also have "... = C $$ (1,2)" unfolding C_def
by (smt "1"(2) A1 A_A1_A2 One_nat_def P1 Q1 append_cols_def carrier_matD(1) carrier_matD(2) diff_Suc_1
dim_col_A_g2 index_mat_four_block index_mult_mat lessI not_numeral_less_one numeral_2_eq_2)
also have "... = E $$ (1,0)" unfolding C_D_E
by (smt "1"(3) A C_D_E C_P1_A_Q1' D One_nat_def append_cols_def carrier_matD less_irrefl_nat
P1 Q1' diff_Suc_1 diff_Suc_Suc index_mat_four_block index_mult_mat lessI numerals(2))
finally have *: "D$$(0,1) dvd E $$(1,0)" by auto
also have "... dvd (P2*E)$$ (0,0)"
by (smt "1"(3) A E E_ij_0 P2 carrier_matD(1) carrier_matD(2) dvd_0_right
dvd_elements_mult_matrix_left dvd_refl pos2 zero_less_diff)
also have "... = H$$(0,2)" unfolding H_def
by (smt "1"(3) A C_D_E C_P1_A_Q1' D Groups.add_ac(1) H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat
H_P2_P1_A_Q1'_Q2' One_nat_def P1 Q1' Q2 add_diff_cancel_left' append_cols_def carrier_matD
index_mat_four_block index_mult_mat less_irrefl_nat numerals(2) plus_1_eq_Suc pos2)
finally show "D $$ (0, 1) dvd H $$ (0, 2)" .
have "E $$(1,0) dvd (P2*E)$$ (1,0)"
by (smt "1"(3) A E E_ij_0 P2 carrier_matD(1) carrier_matD(2) dvd_0_right
dvd_elements_mult_matrix_left dvd_refl rel_simps(49) semiring_norm(76) zero_less_diff)
also have "... = H $$(1,2)" unfolding H_def
by (smt A C_D_E C_P1_A_Q1' D H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2'
One_nat_def P1 Q1' Q2 add_diff_cancel_left' append_cols_def carrier_matD diff_Suc_eq_diff_pred
index_mat_four_block index_mult_mat lessI less_irrefl_nat n_ge_2 numerals(2) plus_1_eq_Suc)
finally show "D$$(0,1) dvd H$$(1,2)" using * by auto
qed
have kH00_eq_H02: "k * H $$ (0, 0) = H $$ (0, 2)"
using id D01_dvd_H02 H00_dvd_D01 unfolding k_def is_div_op_def by auto
have H2_UR_01: "H2_UR $$ (0,1) = 0"
proof -
have "H2_UR $$ (0,1) = H2 $$ (0,2)"
by (metis (no_types, lifting) A H2_P2_P1_A_Q1'_Q2'_Q_div_k H2_UL H2_as_four_block_mat One_nat_def
P2_P1 Q_div_k_def carrier_matD diff_Suc_1 dim_col_A_g2 index_mat_addrow_mat(3)
index_mat_four_block index_mult_mat(2,3) numeral_2_eq_2 pos2 rel_simps(50) rel_simps(68))
also have "... = (-k) * H $$ (0, 0) + H $$ (0, 2)"
by (unfold H2_def, rule index_mat_addcol[of _ ], insert H A n_ge_2, auto)
also have "... = 0" using kH00_eq_H02 by auto
finally show ?thesis .
qed
have H2_UR_0: "H2_UR = (0⇩m 1 (n - 1))"
by (rule eq_matI, insert H2_UR_0j H2_UR_01 H2_UR_00 H2_UR A nat_neq_iff, auto)
have H2_UL_H: "H2_UL $$ (0,0) = H $$ (0,0)"
proof -
have "H2_UL $$ (0,0) = H2 $$ (0,0)"
by (metis (no_types, lifting) Pair_inject index_mat(1) split_H2 split_block_def
zero_less_one_class.zero_less_one)
also have "... = H $$ (0,0)"
unfolding H2_def by (rule index_mat_addcol, insert H A n_ge_2, auto)
finally show ?thesis .
qed
have H2_DL_H_10: "H2_DL $$ (0,0) = H$$(1,0)"
proof -
have "H2_DL $$ (0,0) = H2 $$ (1,0)"
by (smt H2_DL One_nat_def Pair_inject add.right_neutral add_Suc_right carrier_matD(1)
dim_row_mat(1) index_mat(1) rel_simps(68) split_H2 split_block_def split_conv)
also have "... = H$$(1,0)" unfolding H2_def by (rule index_mat_addcol, insert H A n_ge_2, auto)
finally show ?thesis .
qed
have H_10: "H $$(1,0) = 0"
proof -
have "H $$(1,0) = (P2 * D * Q2) $$ (1,0)" unfolding H_def
by (smt A C_D_E C_P1_A_Q1' D E One_nat_def P1 P2_P1 Q2 Q2' Q2'_def Suc_lessD append_cols_def
carrier_matD dim_col_A_g2 index_mat_four_block index_mult_mat index_one_mat
index_zero_mat lessI numerals(2))
also have "... = 0" using is_SNF_D P2D2Q2 D
unfolding is_SNF_def Smith_normal_form_mat_def isDiagonal_mat_def by auto
finally show ?thesis .
qed
have S_H2_Q3': "S = H2 * Q3'"
and S_as_four_block_mat: "S = four_block_mat (H2_UL) (0⇩m 1 (n - 1)) (H2_DL) (H2_DR * Q3)"
proof -
have "H2 * Q3' = four_block_mat (H2_UL * 1⇩m 1 + H2_UR * 0⇩m (dim_col A - 1) 1)
(H2_UL * 0⇩m 1 (dim_col A - 1) + H2_UR * Q3)
(H2_DL * 1⇩m 1 + H2_DR * 0⇩m (dim_col A - 1) 1) (H2_DL * 0⇩m 1 (dim_col A - 1) + H2_DR * Q3)"
unfolding H2_as_four_block_mat Q3'_def
by (rule mult_four_block_mat[OF H2_UL H2_UR H2_DL H2_DR], insert Q3 A H', auto)
also have "... = four_block_mat (H2_UL) (0⇩m 1 (n - 1)) (H2_DL) (H2_DR * Q3)"
by (rule cong_four_block_mat, insert H2_UR_0 H2_UL H2_UR H2_DL H2_DR Q3, auto)
also have *: "... = S" unfolding S_def
proof (rule cong_four_block_mat)
show "H2_UL = Matrix.mat 1 1 (λ(a, b). H $$ (0, 0))"
by (rule eq_matI, insert H2_UL H2_UL_H, auto)
show "H2_DR * Q3 = H_1xn" using is_SNF_H' unfolding is_SNF_def by auto
show "0⇩m 1 (n - 1) = 0⇩m 1 (dim_col A - 1)" using A by auto
show "H2_DL = 0⇩m 1 1" using H2_DL H2_DL_H_10 H_10 by auto
qed
finally show "S = H2 * Q3'"
and "S = four_block_mat (H2_UL) (0⇩m 1 (n - 1)) (H2_DL) (H2_DR * Q3)"
using * by auto
qed
thus "S = P2 * P1 * A * (Q1' * Q2' * Q_div_k * Q3')" unfolding H2_P2_P1_A_Q1'_Q2'_Q_div_k
by (smt Q1' Q2' Q2'_def Q3' Q3'_def Q_div_k assoc_mult_mat
carrier_matD carrier_mat_triv index_mult_mat)
show "Smith_normal_form_mat S"
proof (rule Smith_normal_form_mat_intro)
have Sij_0: "S$$(i,j) = 0" if ij: "i ≠ j" and i: "i < dim_row S" and j: "j < dim_col S" for i j
proof (cases "i=1 ∧ j=0")
case True
have "S$$(1,0) = 0" using S_as_four_block_mat
by (metis (no_types, lifting) H2_DL_H_10 H2_UL H_10 One_nat_def True carrier_matD diff_Suc_1
index_mat_four_block rel_simps(71) that(2) that(3) zero_less_one_class.zero_less_one)
then show ?thesis using True by auto
next
case False note not_10 = False
show ?thesis
proof (cases "i=0")
case True
hence j0: "j>0" using ij by auto
then show ?thesis using S_as_four_block_mat
by (smt "1"(2) H2_DR H2_H_Q_div_k H2_UL H_P2_P1_A_Q1'_Q2' Num.numeral_nat(7) P2_P1 Q3 S_H2_Q3'
Suc_pred True carrier_matD index_mat_four_block index_mult_mat index_zero_mat(1)
not_less_eq plus_1_eq_Suc pos2 that(3) zero_less_one_class.zero_less_one)
next
case False
have SNF_H_1xn: "Smith_normal_form_mat H_1xn" using is_SNF_H' unfolding is_SNF_def by auto
have i1: "i=1" using False ij i H2_DR H2_UL S_as_four_block_mat by auto
hence j1: "j>1" using ij not_10 by auto thm is_SNF_H'
have "S$$(i,j) = (if i < dim_row H2_UL then if j < dim_col H2_UL then H2_UL $$ (i, j)
else (0⇩m 1 (n - 1)) $$ (i, j - dim_col H2_UL)
else if j < dim_col H2_UL then H2_DL $$ (i - dim_row H2_UL, j)
else (H2_DR * Q3) $$ (i - dim_row H2_UL, j - dim_col H2_UL))"
unfolding S_as_four_block_mat
by (rule index_mat_four_block, insert i j H2_UL H2_DR Q3 S_H2_Q3' H2 Q3' A, auto)
also have "... = (H2_DR * Q3) $$ (0, j - 1)" using H2_UL i1 not_10 by auto
also have "... = H_1xn $$ (0,j-1)"
using S_def calculation i1 j not_10 i by auto
also have "... = 0" using SNF_H_1xn j1 i j
unfolding Smith_normal_form_mat_def isDiagonal_mat_def
by (simp add: S_def i1)
finally show ?thesis .
qed
qed
thus "isDiagonal_mat S" unfolding isDiagonal_mat_def by auto
have "S$$(0,0) dvd S$$(1,1)"
proof -
have dvd_all: "∀i j. i < 2 ∧ j < n ⟶ H2_UL$$(0,0) dvd (H2 * Q3') $$ (i, j)"
proof (rule dvd_elements_mult_matrix_right)
show H2': "H2 ∈ carrier_mat 2 n" using H2 A by auto
show "Q3' ∈ carrier_mat n n" using Q3' A by auto
have "H2_UL $$ (0, 0) dvd H2 $$ (i, j)" if i: "i < 2" and j: "j < n" for i j
proof (cases "i=0")
case True
then show ?thesis
by (metis (no_types, lifting) A H2_H_Q_div_k H2_UL H2_UR_0 H2_as_four_block_mat
H_P2_P1_A_Q1'_Q2' P2_P1 Q3 Q_div_k S_as_four_block_mat Sij_0 carrier_matD
dvd_0_right dvd_refl index_mat_four_block index_mult_mat(2,3) j less_one pos2)
next
case False
hence i1: "i=1" using i by auto
have H2_10_0: "H2 $$ (1,0) = 0"
by (metis (no_types, lifting) H2_H_Q_div_k H2_def H_10 H_P2_P1_A_Q1'_Q2' One_nat_def
Q2' H2' basic_trans_rules(19) carrier_matD dim_col_A_g2 index_mat_addcol(3)
index_mult_mat(2,3) lessI numeral_2_eq_2 rel_simps(76))
moreover have H2_UL00_dvd_H211:"H2_UL $$ (0, 0) dvd H2 $$ (1, 1)"
proof -
have "H2_UL $$ (0, 0) = H $$ (0, 0)" by (simp add: H2_UL_H)
also have "... = (P2*D*Q2) $$ (0,0)" unfolding H_def using append_cols_nth D E
by (smt A C_D_E C_P1_A_Q1' D H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat
H_P2_P1_A_Q1'_Q2' One_nat_def P1 Q1' Q2 Suc_lessD append_cols_def carrier_matD
dim_col_A_g2 index_mat_four_block index_mult_mat numerals(2) plus_1_eq_Suc zero_less_Suc)
also have "... dvd (P2*D*Q2) $$ (1,1)"
using is_SNF_D P2D2Q2 unfolding is_SNF_def Smith_normal_form_mat_def by auto
(metis D Q2 carrier_matD index_mult_mat(1) index_mult_mat(2) lessI numerals(2) pos2)
also have "... = H $$ (1,1)" unfolding H_def using append_cols_nth D E
by (smt A C_D_E C_P1_A_Q1' H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2'
One_nat_def P1 Q1' Q2 append_cols_def carrier_matD(1) carrier_matD(2) dim_col_A_g2
index_mat_four_block index_mult_mat(2) index_mult_mat(3) lessI less_trans_Suc
numerals(2) plus_1_eq_Suc pos2)
also have "... = H2 $$ (1, 1)"
by (metis A H2_def H_P2_P1_A_Q1'_Q2' One_nat_def P2_P1 Q2' carrier_matD dim_col_A_g2 i i1
index_mat_addcol(3) index_mult_mat(2) index_mult_mat(3) less_trans_Suc nat_neq_iff pos2)
finally show ?thesis .
qed
moreover have H2_UL00_dvd_H212: "H2_UL $$ (0, 0) dvd H2 $$ (1, 2)"
proof -
have "H2_UL $$ (0, 0) = H $$ (0, 0)" by (simp add: H2_UL_H)
also have "... dvd H $$ (1,2)" using D01_dvd_H12 H00_dvd_D01 dvd_trans by blast
also have "... = (-k) * H $$ (1,0) + H $$ (1,2)"
using H_10 by auto
also have "... = H2 $$ (1,2)"
unfolding H2_def by (rule index_mat_addcol[symmetric], insert H A n_ge_2, auto)
finally show ?thesis .
qed
moreover have "H2 $$ (1, j) = 0" if j1: "j>2" and j: "j<n"
proof -
let ?f = "(λ(i, j). ∑ia = 0..<dim_vec (col E j). Matrix.row P2 i $v ia * col E j $v ia)"
have "H2 $$ (1, j) = H $$ (1,j)" unfolding H2_def using j j1 n_ge_2
by (metis (mono_tags, lifting) "1"(2) H2' H_10 H_P2_P1_A_Q1'_Q2' Q2' arithmetic_simps(49)
carrier_matD i i1 index_mat_addcol(1) index_mult_mat semiring_norm(64) H2_H_Q_div_k)
also have "... = (P2*E)$$ (1,j-2)" unfolding H_def
by (smt A C_D_E C_P1_A_Q1' D H2' H2_H_Q_div_k H_P2_P1_A_Q1'_Q2' P1 Q1' Q2 append_cols_def
basic_trans_rules(19) carrier_matD index_mat_four_block index_mult_mat(2)
index_mult_mat(3) j less_one nat_neq_iff not_less_less_Suc_eq numerals(2) j1)
also have "... = Matrix.mat (dim_row P2) (dim_col E) ?f $$ (1, j - 2)"
unfolding times_mat_def scalar_prod_def by simp
also have "... = ?f (1,j-2)" by (rule index_mat, insert P2 E E_def n_ge_2 j j1 A, auto)
also have "... = (∑ia = 0..<2. Matrix.row P2 1 $v ia * col E (j-2) $v ia)"
using E A E_def j j1 by auto
also have "... = (∑ia ∈ {0,1}. Matrix.row P2 1 $v ia * col E (j-2) $v ia)"
by (rule sum.cong, auto)
also have "... = Matrix.row P2 1 $v 0 * col E (j - 2) $v 0
+ Matrix.row P2 1 $v 1 * col E (j - 2) $v 1"
by (simp add: sum_two_elements[OF zero_neq_one])
also have "... = 0" using E_ij_0 E_def E A
by (auto, smt D Q2 Q2' Q2'_def Suc_lessD add_cancel_right_right add_diff_inverse_nat
arith_extra_simps(19) carrier_matD i i1 index_col index_mat_four_block(3)
index_one_mat(3) less_2_cases nat_add_left_cancel_less numeral_2_eq_2
semiring_norm(138) semiring_norm(160) j j1 zero_less_diff)
finally show ?thesis .
qed
ultimately show ?thesis using i1 False
by (metis One_nat_def dvd_0_right less_2_cases nat_neq_iff j)
qed
thus "∀i j. i < 2 ∧ j < n ⟶ H2_UL $$ (0, 0) dvd H2 $$ (i, j)" by auto
qed
have "S$$(0,0) = H2_UL $$ (0,0)" using H2_UL S_as_four_block_mat by auto
also have "... dvd (H2*Q3') $$ (1,1)" using dvd_all n_ge_2 by auto
also have "... = S $$ (1,1)" using S_H2_Q3' by auto
finally show ?thesis .
qed
thus "∀a. a + 1 < min (dim_row S) (dim_col S) ⟶ S $$ (a, a) dvd S $$ (a + 1, a + 1)"
by (metis "1"(2) H2_H_Q_div_k H_P2_P1_A_Q1'_Q2' One_nat_def P2_P1 S_H2_Q3' Suc_eq_plus1
index_mult_mat(2) less_Suc_eq less_one min_less_iff_conj numeral_2_eq_2 carrier_matD(1))
qed
qed
qed
lemma is_SNF_Smith_2xn:
assumes A: "A ∈ carrier_mat 2 n"
shows "is_SNF A (Smith_2xn A)"
proof (cases "n>2")
case True
then show ?thesis using is_SNF_Smith_2xn_n_ge_2[OF A] by simp
next
case False
hence "n=0 ∨ n=1 ∨ n=2" by auto
then show ?thesis using Smith_2xn_0 Smith_2xn_1 Smith_2xn_2 A by blast
qed
subsubsection ‹Case $n \times 2$›
definition "Smith_nx2 A = (let (P,S,Q) = Smith_2xn A⇧T in
(Q⇧T, S⇧T, P⇧T))"
lemma is_SNF_Smith_nx2:
assumes A: "A ∈ carrier_mat n 2"
shows "is_SNF A (Smith_nx2 A)"
proof -
obtain P S Q where PSQ: "(P,S,Q) = Smith_2xn A⇧T" by (metis prod_cases3)
hence rw: "Smith_nx2 A = (Q⇧T, S⇧T, P⇧T)" unfolding Smith_nx2_def by (metis split_conv)
have "is_SNF A⇧T (Smith_2xn A⇧T)" by (rule is_SNF_Smith_2xn, insert id A, auto)
hence is_SNF_PSQ: "is_SNF A⇧T (P,S,Q)" using PSQ by auto
show ?thesis
proof (unfold rw, rule is_SNF_intro)
show Qt: "Q⇧T ∈ carrier_mat (dim_row A) (dim_row A)"
and Pt: "P⇧T ∈ carrier_mat (dim_col A) (dim_col A)"
and "invertible_mat Q⇧T" and "invertible_mat P⇧T"
using is_SNF_PSQ invertible_mat_transpose unfolding is_SNF_def by auto
have "Smith_normal_form_mat S" and PATQ: "S = P * A⇧T * Q"
using is_SNF_PSQ invertible_mat_transpose unfolding is_SNF_def by auto
thus "Smith_normal_form_mat S⇧T" unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto
show "S⇧T = Q⇧T * A * P⇧T" using PATQ
by (smt Matrix.transpose_mult Matrix.transpose_transpose Pt Qt assoc_mult_mat
carrier_mat_triv index_mult_mat(2))
qed
qed
subsubsection ‹Case $m \times n$›
declare Smith_2xn.simps[simp del]
function (domintros) Smith_mxn :: "'a mat ⇒ ('a mat × 'a mat × 'a mat)"
where
"Smith_mxn A = (
if dim_row A = 0 ∨ dim_col A = 0 then (1⇩m (dim_row A),A,1⇩m (dim_col A))
else if dim_row A = 1 then (1⇩m 1, Smith_1xn A)
else if dim_row A = 2 then Smith_2xn A
else if dim_col A = 1 then let (P,S) = Smith_nx1 A in (P,S,1⇩m 1)
else if dim_col A = 2 then Smith_nx2 A
else
let A1 = mat_of_row (Matrix.row A 0);
A2 = mat_of_rows (dim_col A) [Matrix.row A i. i ← [1..<dim_row A]];
(P1,D1,Q1) = Smith_mxn A2;
C = (A1*Q1) @⇩r (P1*A2*Q1);
D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1];
E = mat_of_rows (dim_col A) [Matrix.row C i. i ← [2..<dim_row A]];
(P2,F,Q2) = Smith_2xn D;
H = (P2*D*Q2) @⇩r (E*Q2);
(P_H2, H2) = reduce_column div_op H;
(H2_UL, H2_UR, H2_DL, H2_DR) = split_block H2 1 1;
(P3,S',Q3) = Smith_mxn H2_DR;
S = four_block_mat (Matrix.mat 1 1 (λ(a, b). H $$ (0, 0))) (0⇩m 1 (dim_col A - 1)) (0⇩m (dim_row A - 1) 1) S';
P1' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_row A - 1)) (0⇩m (dim_row A - 1) 1) P1;
P2' = four_block_mat P2 (0⇩m 2 (dim_row A - 2)) (0⇩m (dim_row A - 2) 2) (1⇩m (dim_row A - 2));
P3' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_row A - 1)) (0⇩m (dim_row A - 1) 1) P3;
Q3' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_col A - 1)) (0⇩m (dim_col A - 1) 1) Q3
in (P3' * P_H2 * P2' * P1',S, Q1 * Q2 * Q3')
)"
by pat_completeness fast
declare Smith_2xn.simps[simp]
lemma Smith_mxn_dom_nm_less_2:
assumes A: "A ∈ carrier_mat m n" and mn: "n≤2 ∨ m≤2"
shows "Smith_mxn_dom A"
by (rule Smith_mxn.domintros, insert assms, auto)
lemma Smith_mxn_pinduct_carrier_less_2:
assumes A: "A ∈ carrier_mat m n" and mn: "n≤2 ∨ m≤2"
shows "fst (Smith_mxn A) ∈ carrier_mat m m
∧ fst (snd (Smith_mxn A)) ∈ carrier_mat m n
∧ snd (snd (Smith_mxn A)) ∈ carrier_mat n n"
proof -
have A_dom: "Smith_mxn_dom A" using Smith_mxn_dom_nm_less_2[OF assms] by simp
show ?thesis
proof (cases "dim_row A = 0 ∨ dim_col A = 0")
case True
have "Smith_mxn A = (1⇩m (dim_row A),A,1⇩m (dim_col A))"
using Smith_mxn.psimps[OF A_dom] True by auto
thus ?thesis using A by auto
next
case False note 1 = False
show ?thesis
proof (cases "dim_row A = 1")
case True
have "Smith_mxn A = (1⇩m 1, Smith_1xn A)"
using Smith_mxn.psimps[OF A_dom] True 1 by auto
then show ?thesis using Smith_1xn_works unfolding is_SNF_def
by (smt Smith_1xn_aux_Q_carrier Smith_1xn_aux_S'_AQ' Smith_1xn_def True assms(1) carrier_matD
carrier_matI diff_less fst_conv index_mult_mat not_gr0 one_carrier_mat prod.collapse
right_mult_one_mat' snd_conv zero_less_one_class.zero_less_one)
next
case False note 2 = False
then show ?thesis
proof (cases "dim_row A = 2")
case True
hence A': "A ∈ carrier_mat 2 n" using A by auto
have "Smith_mxn A = Smith_2xn A" using Smith_mxn.psimps[OF A_dom] True 1 2 by auto
then show ?thesis using is_SNF_Smith_2xn[OF A'] A unfolding is_SNF_def
by (metis (mono_tags, lifting) carrier_matD carrier_mat_triv case_prod_beta index_mult_mat(2,3))
next
case False note 3 = False
show ?thesis
proof (cases "dim_col A = 1")
case True
hence A': "A ∈ carrier_mat m 1" using A by auto
have "Smith_mxn A = (let (P,S) = Smith_nx1 A in (P,S,1⇩m 1))"
using Smith_mxn.psimps[OF A_dom] True 1 2 3 by auto
then show ?thesis using Smith_nx1_works[OF A'] A unfolding is_SNF_def
by (metis (mono_tags, lifting) carrier_matD carrier_mat_triv case_prod_unfold
index_mult_mat(2,3) surjective_pairing)
next
case False
hence "dim_col A = 2" using 1 2 3 mn A by auto
hence A': "A ∈ carrier_mat m 2" using A by auto
hence "Smith_mxn A = Smith_nx2 A"
using Smith_mxn.psimps[OF A_dom] 1 2 3 False by auto
then show ?thesis using is_SNF_Smith_nx2[OF A'] A unfolding is_SNF_def by force
qed
qed
qed
qed
qed
lemma Smith_mxn_pinduct_carrier_ge_2: "⟦Smith_mxn_dom A; A ∈ carrier_mat m n; m>2; n>2⟧ ⟹
fst (Smith_mxn A) ∈ carrier_mat m m
∧ fst (snd (Smith_mxn A)) ∈ carrier_mat m n
∧ snd (snd (Smith_mxn A)) ∈ carrier_mat n n"
proof (induct arbitrary: m n rule: Smith_mxn.pinduct)
case (1 A)
note A_dom = 1(1)
note A = "1.prems"(1)
note m = "1.prems"(2)
note n = "1.prems"(3)
define A1 where "A1 = mat_of_row (Matrix.row A 0)"
define A2 where "A2 = mat_of_rows (dim_col A) [Matrix.row A i. i ← [1..<dim_row A]]"
obtain P1 D1 Q1 where P1D1Q1: "(P1,D1,Q1) = Smith_mxn A2" by (metis prod_cases3)
define C where "C = (A1*Q1) @⇩r (P1*A2*Q1)"
define D where "D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1]"
define E where "E = mat_of_rows (dim_col A) [Matrix.row C i. i ← [2..<dim_row A]]"
obtain P2 F Q2 where P2FQ2: "(P2,F,Q2) = Smith_2xn D" by (metis prod_cases3)
define H where "H = (P2*D*Q2) @⇩r (E*Q2)"
obtain P_H2 H2 where P_H2H2: "(P_H2, H2) = reduce_column div_op H" by (metis surj_pair)
obtain H2_UL H2_UR H2_DL H2_DR where split_H2: "(H2_UL, H2_UR, H2_DL, H2_DR) = split_block H2 1 1"
by (metis split_block_def)
obtain P3 S' Q3 where P3S'Q3: "(P3,S',Q3) = Smith_mxn H2_DR" by (metis prod_cases3)
define S where "S = four_block_mat (Matrix.mat 1 1 (λ(a, b). H $$ (0, 0))) (0⇩m 1 (dim_col A - 1))
(0⇩m (dim_row A - 1) 1) S'"
define P1' where "P1' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_row A - 1)) (0⇩m (dim_row A - 1) 1) P1"
define P2' where "P2' = four_block_mat P2 (0⇩m 2 (dim_row A - 2)) (0⇩m (dim_row A - 2) 2) (1⇩m (dim_row A - 2))"
define P3' where "P3' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_row A - 1)) (0⇩m (dim_row A - 1) 1) P3"
define Q3' where "Q3' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_col A - 1)) (0⇩m (dim_col A - 1) 1) Q3"
have A1: "A1 ∈ carrier_mat 1 n" unfolding A1_def using A by auto
have A2: "A2 ∈ carrier_mat (m-1) n" unfolding A2_def using A by auto
have "fst (Smith_mxn A2) ∈ carrier_mat (m-1) (m-1)
∧ fst (snd (Smith_mxn A2)) ∈ carrier_mat (m-1) n
∧ snd (snd (Smith_mxn A2)) ∈ carrier_mat n n"
proof (cases "2 < m - 1")
case True
show ?thesis by (rule "1.hyps"(2), insert A m n A2_def A1_def True id, auto)
next
case False
hence "m=3" using m by auto
hence A2': "A2 ∈ carrier_mat 2 n" using A2 by auto
have A2_dom: "Smith_mxn_dom A2" by (rule Smith_mxn.domintros, insert A2', auto)
have "dim_row A2 = 2" using A2 A2' by fast
hence "Smith_mxn A2 = Smith_2xn A2"
using n unfolding Smith_mxn.psimps[OF A2_dom] by auto
then show ?thesis using is_SNF_Smith_2xn[OF A2'] m A2 unfolding is_SNF_def split_beta
by (metis carrier_matD carrier_matI index_mult_mat(2,3))
qed
hence P1: "P1 ∈ carrier_mat (m-1) (m-1)"
and D1: "D1 ∈ carrier_mat (m-1) n"
and Q1: "Q1 ∈ carrier_mat n n" using P1D1Q1 by (metis fst_conv snd_conv)+
have "C ∈ carrier_mat (1 + (m-1)) n" unfolding C_def
by (rule carrier_append_rows, insert P1 D1 Q1 A1, auto)
hence C: "C ∈ carrier_mat m n" using m by simp
have D: "D ∈ carrier_mat 2 n" unfolding D_def using C A by auto
have E: "E ∈ carrier_mat (m-2) n" unfolding E_def using A by auto
have P2: "P2 ∈ carrier_mat 2 2" and Q2: "Q2 ∈ carrier_mat n n"
using is_SNF_Smith_2xn[OF D] P2FQ2 D unfolding is_SNF_def by auto
have "H ∈ carrier_mat (2 + (m-2)) n" unfolding H_def
by (rule carrier_append_rows, insert P2 D Q2 E, auto)
hence H: "H ∈ carrier_mat m n" using m by auto
have H2: "H2 ∈ carrier_mat m n" using m H P_H2H2 reduce_column by blast
have H2_DR: "H2_DR ∈ carrier_mat (m - 1) (n - 1)"
by (rule split_block(4)[OF split_H2[symmetric]], insert H2 m n, auto)
have "fst (Smith_mxn H2_DR) ∈ carrier_mat (m-1) (m-1)
∧ fst (snd (Smith_mxn H2_DR)) ∈ carrier_mat (m-1) (n-1)
∧ snd (snd (Smith_mxn H2_DR)) ∈ carrier_mat (n-1) (n-1)"
proof (cases "2<m-1 ∧ 2<n-1")
case True
show ?thesis
proof (rule "1.hyps"(3)[OF _ _ _ _ _ A1_def A2_def P1D1Q1 _ _ C_def])
show "(P2,F,Q2) = Smith_2xn D" using P2FQ2 by auto
qed (insert A P1D1Q1 D_def E_def P2FQ2 P_H2H2 P3S'Q3 H_def split_H2 H2_DR True id, auto)
next
case False note m_eq_3_or_n_eq_3 = False
show ?thesis
proof (cases "(2 < m - 1)")
case True
hence n3: "n=3" using m_eq_3_or_n_eq_3 n m by auto
have H2_DR_dom: "Smith_mxn_dom H2_DR"
by (rule Smith_mxn.domintros, insert H2_DR n3, auto)
have H2_DR': "H2_DR ∈ carrier_mat (m-1) 2" using H2_DR n3 by auto
hence "dim_col H2_DR = 2" by simp
hence "Smith_mxn H2_DR = Smith_nx2 H2_DR"
using n H2_DR' True unfolding Smith_mxn.psimps[OF H2_DR_dom] by auto
then show ?thesis using is_SNF_Smith_nx2[OF H2_DR'] m H2_DR unfolding is_SNF_def by auto
next
case False
hence m3: "m=3" using m_eq_3_or_n_eq_3 n m by auto
have H2_DR_dom: "Smith_mxn_dom H2_DR"
by (rule Smith_mxn.domintros, insert H2_DR m3, auto)
have H2_DR': "H2_DR ∈ carrier_mat 2 (n-1)" using H2_DR m3 by auto
hence "dim_row H2_DR = 2" by simp
hence "Smith_mxn H2_DR = Smith_2xn H2_DR"
using n H2_DR' unfolding Smith_mxn.psimps[OF H2_DR_dom] by auto
then show ?thesis using is_SNF_Smith_2xn[OF H2_DR'] m H2_DR unfolding is_SNF_def by force
qed
qed
hence P3: "P3 ∈ carrier_mat (m-1) (m-1)"
and S': "S'∈ carrier_mat (m-1) (n-1)"
and Q3: "Q3 ∈ carrier_mat (n-1) (n-1)" using P3S'Q3 by (metis fst_conv snd_conv)+
have Smith_final: "Smith_mxn A = (P3' * P_H2 * P2' * P1', S, Q1 * Q2 * Q3')"
proof -
have P1_def: "P1 = fst (Smith_mxn A2)" and D1_def: "D1 = fst (snd (Smith_mxn A2))"
and Q1_def: "Q1 = snd (snd (Smith_mxn A2))" using P1D1Q1 by (metis fstI sndI)+
have P2_def: "P2 = fst (Smith_2xn D)" and F_def: "F = fst (snd (Smith_2xn D))"
and Q2_def: "Q2 = snd (snd (Smith_2xn D))" using P2FQ2 by (metis fstI sndI)+
have P_H2_def: "P_H2 = fst (reduce_column div_op H)"
and H2_def: "H2 = snd (reduce_column div_op H)"
using P_H2H2 by (metis fstI sndI)+
have H2_UL_def: "H2_UL = fst (split_block H2 1 1)"
and H2_UR_def: "H2_UR = fst (snd (split_block H2 1 1))"
and H2_DL_def: "H2_DL = fst (snd (snd (split_block H2 1 1)))"
and H2_DR_def: "H2_DR = snd (snd (snd (split_block H2 1 1)))"
using split_H2 by (metis fstI sndI)+
have P3_def: "P3 = fst (Smith_mxn H2_DR)"
and S'_def: "S' = fst (snd (Smith_mxn H2_DR))"
and Q3_def: "Q3 = (snd (snd (Smith_mxn H2_DR)))" using P3S'Q3 by (metis fstI sndI)+
note aux = Smith_mxn.psimps[OF A_dom] Let_def split_beta
A1_def[symmetric] A2_def[symmetric] P1_def[symmetric] D1_def[symmetric] Q1_def[symmetric]
C_def[symmetric] D_def[symmetric] E_def[symmetric] P2_def[symmetric] Q2_def[symmetric]
F_def[symmetric] H_def[symmetric] P_H2_def[symmetric] H2_def[symmetric] H2_UL_def[symmetric]
H2_DL_def[symmetric] H2_UR_def[symmetric] H2_DR_def[symmetric] P3_def[symmetric] S'_def[symmetric]
Q3_def[symmetric] P1'_def[symmetric] P2'_def[symmetric] P3'_def[symmetric] Q1_def[symmetric]
Q2_def[symmetric] Q3'_def[symmetric] S_def[symmetric]
show ?thesis by (rule prod3_intro, unfold aux, insert "1.prems", auto)
qed
have P1': "P1' ∈ carrier_mat m m" unfolding P1'_def using P1 m by auto
moreover have P2': "P2' ∈ carrier_mat m m" unfolding P2'_def using P2 m A by auto
moreover have P3': "P3' ∈ carrier_mat m m" unfolding P3'_def using P3 m by auto
moreover have P_H2: "P_H2 ∈ carrier_mat m m" using reduce_column[OF H P_H2H2] m by simp
moreover have "S ∈ carrier_mat m n" unfolding S_def using H A S'
by (auto, smt C One_nat_def Suc_pred ‹C ∈ carrier_mat (1 + (m - 1)) n› carrier_matD carrier_matI
dim_col_mat(1) dim_row_mat(1) index_mat_four_block n neq0_conv plus_1_eq_Suc zero_order(3))
moreover have "Q3' ∈ carrier_mat n n" unfolding Q3'_def using Q3 n by auto
ultimately show ?case using Smith_final Q1 Q2 by auto
qed
corollary Smith_mxn_pinduct_carrier: "⟦Smith_mxn_dom A; A ∈ carrier_mat m n⟧ ⟹
fst (Smith_mxn A) ∈ carrier_mat m m
∧ fst (snd (Smith_mxn A)) ∈ carrier_mat m n
∧ snd (snd (Smith_mxn A)) ∈ carrier_mat n n"
using Smith_mxn_pinduct_carrier_ge_2 Smith_mxn_pinduct_carrier_less_2
by (meson linorder_not_le)
termination proof (relation "measure (λA. dim_row A)")
fix A A1 A2 xb P1 y D1 Q1 C D E xf P2 yb Q2 F yc H xj P_H2 H2 xl xm ye xn yf xo yg
assume 1: "¬ (dim_row A = 0 ∨ dim_col A = 0)" and 2: "dim_row A ≠ 1"
and 3: "dim_row A ≠ 2" and 4: "dim_col A ≠ 1" and 5: "dim_col A ≠ 2"
and 6: "A1 = mat_of_row (Matrix.row A 0)"
and xa_def: "A2 = mat_of_rows (dim_col A) (map (Matrix.row A) [1..<dim_row A])"
and xb_def: "xb = Smith_mxn A2" and P1_y_xb: "(P1, y) = xb "
and D1_Q1_y: "(D1, Q1) = y " and C_def: "C = A1 * Q1 @⇩r P1* A2 * Q1 "
and D_def: "D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1] "
and E_def: "E = mat_of_rows (dim_col A) (map (Matrix.row C) [2..<dim_row A]) "
and xf: "xf = Smith_2xn D" and P2_yb_xf: "(P2, yb) = xf" and F_Q2_yb: "(F, Q2) = yb "
and H_def: "H = P2 * D * Q2 @⇩r E * Q2 " and xj: "xj = reduce_column div_op H "
and P_H2_H2: "(P_H2, H2) = xj" and b4: "xl = split_block H2 1 1 "
and b1: "(xm, ye) = xl" and b2: "(xn, yf) = ye" and b3: "(xo, yg) = yf"
and A2_dom: "Smith_mxn_dom A2"
let ?m = "dim_row A"
let ?n = "dim_col A"
have m: "2< ?m" and n: "2 < ?n" using 1 2 3 4 5 6 by auto
have A1: "A1 ∈ carrier_mat 1 (dim_col A)" using 6 by auto
have A2: "A2 ∈ carrier_mat (dim_row A - 1) (dim_col A)" using xa_def by auto
have "fst (Smith_mxn A2) ∈ carrier_mat (?m-1) (?m-1)
∧ fst (snd (Smith_mxn A2)) ∈ carrier_mat (?m-1) ?n
∧ snd (snd (Smith_mxn A2)) ∈ carrier_mat ?n ?n"
by (rule Smith_mxn_pinduct_carrier[OF A2_dom A2])
hence P1: "P1∈ carrier_mat (?m-1) (?m-1)"and D1: "D1 ∈ carrier_mat (?m-1) ?n"
and Q1: "Q1 ∈ carrier_mat ?n ?n" using P1_y_xb D1_Q1_y xa_def xb_def by (metis fstI sndI)+
have C: "C ∈ carrier_mat ?m ?n" unfolding C_def using A1 Q1 P1 A2 Q1
by (smt 1 Suc_pred card_num_simps(30) carrier_append_rows mult_carrier_mat neq0_conv plus_1_eq_Suc)
have D: "D ∈ carrier_mat 2 ?n" unfolding D_def using C by auto
have E: "E ∈ carrier_mat (?m-2) ?n" unfolding E_def using C m by auto
have P2FQ2: "(P2,F,Q2) = Smith_2xn D" using F_Q2_yb P2_yb_xf xf by blast
have P2: "P2∈carrier_mat 2 2" and F: "F ∈ carrier_mat 2 ?n" and Q2: "Q2 ∈ carrier_mat ?n ?n"
using is_SNF_Smith_2xn[OF D] D P2FQ2 unfolding is_SNF_def by auto
have "H ∈ carrier_mat (2 + (?m-2)) ?n"
by (unfold H_def, rule carrier_append_rows, insert D Q2 P2 E, auto)
hence H: "H ∈ carrier_mat ?m ?n" using m by auto
have H2: "H2 ∈ carrier_mat (dim_row H) (dim_col H)"
and P_H2: "P_H2 ∈ carrier_mat (dim_row A) (dim_row A)"
using reduce_column[OF H xj[unfolded P_H2_H2[symmetric]]] m H by auto
have "dim_row yg < dim_row H2"
by (rule split_block4_decreases_dim_row, insert b1 b2 b3 b4 m n H H2, auto)
also have "... = dim_row A" using H2 H by auto
finally show "(yg, A) ∈ measure dim_row" unfolding in_measure .
qed (auto)
lemma is_SNF_Smith_mxn_less_2:
assumes A: "A ∈ carrier_mat m n" and mn: "n≤2 ∨ m≤2"
shows "is_SNF A (Smith_mxn A)"
proof -
show ?thesis
proof (cases "dim_row A = 0 ∨ dim_col A = 0")
case True
have "Smith_mxn A = (1⇩m (dim_row A),A,1⇩m (dim_col A))"
using Smith_mxn.simps True by auto
thus ?thesis using A True unfolding is_SNF_def by auto
next
case False note 1 = False
show ?thesis
proof (cases "dim_row A = 1")
case True
have "Smith_mxn A = (1⇩m 1, Smith_1xn A)"
using Smith_mxn.simps True 1 by auto
then show ?thesis using Smith_1xn_works by (metis True carrier_mat_triv surj_pair)
next
case False note 2 = False
then show ?thesis
proof (cases "dim_row A = 2")
case True
hence A': "A ∈ carrier_mat 2 n" using A by auto
have "Smith_mxn A = Smith_2xn A" using Smith_mxn.simps True 1 2 by auto
then show ?thesis using is_SNF_Smith_2xn[OF A'] A by auto
next
case False note 3 = False
show ?thesis
proof (cases "dim_col A = 1")
case True
hence A': "A ∈ carrier_mat m 1" using A by auto
have "Smith_mxn A = (let (P,S) = Smith_nx1 A in (P,S,1⇩m 1))"
using Smith_mxn.simps True 1 2 3 by auto
then show ?thesis using Smith_nx1_works[OF A'] A by (auto simp add: case_prod_beta)
next
case False
hence "dim_col A = 2" using 1 2 3 mn A by auto
hence A': "A ∈ carrier_mat m 2" using A by auto
hence "Smith_mxn A = Smith_nx2 A"
using Smith_mxn.simps 1 2 3 False by auto
then show ?thesis using is_SNF_Smith_nx2[OF A'] A by force
qed
qed
qed
qed
qed
lemma is_SNF_Smith_mxn_ge_2:
assumes A: "A ∈ carrier_mat m n" and m: "m>2" and n: "n>2"
shows "is_SNF A (Smith_mxn A)"
using A m n
proof (induct A arbitrary: m n rule: Smith_mxn.induct)
case (1 A)
note A = "1.prems"(1)
note m = "1.prems"(2)
note n = "1.prems"(3)
have A_dim_not0: "¬ (dim_row A = 0 ∨ dim_col A = 0)" and A_dim_row_not1: "dim_row A ≠ 1"
and A_dim_row_not2: "dim_row A ≠ 2" and A_dim_col_not1: "dim_col A ≠ 1"
and A_dim_col_not2: "dim_col A ≠ 2"
using A m n by auto
note A_dim_intro = A_dim_not0 A_dim_row_not1 A_dim_row_not2 A_dim_col_not1 A_dim_col_not2
define A1 where "A1 = mat_of_row (Matrix.row A 0)"
define A2 where "A2 = mat_of_rows (dim_col A) [Matrix.row A i. i ← [1..<dim_row A]]"
obtain P1 D1 Q1 where P1D1Q1: "(P1,D1,Q1) = Smith_mxn A2" by (metis prod_cases3)
define C where "C = (A1*Q1) @⇩r (P1*A2*Q1)"
define D where "D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1]"
define E where "E = mat_of_rows (dim_col A) [Matrix.row C i. i ← [2..<dim_row A]]"
obtain P2 F Q2 where P2FQ2: "(P2,F,Q2) = Smith_2xn D" by (metis prod_cases3)
define H where "H = (P2*D*Q2) @⇩r (E*Q2)"
obtain P_H2 H2 where P_H2H2: "(P_H2, H2) = reduce_column div_op H" by (metis surj_pair)
obtain H2_UL H2_UR H2_DL H2_DR where split_H2: "(H2_UL, H2_UR, H2_DL, H2_DR) = split_block H2 1 1"
by (metis split_block_def)
obtain P3 S' Q3 where P3S'Q3: "(P3,S',Q3) = Smith_mxn H2_DR" by (metis prod_cases3)
define S where "S = four_block_mat (Matrix.mat 1 1 (λ(a, b). H $$ (0, 0))) (0⇩m 1 (dim_col A - 1))
(0⇩m (dim_row A - 1) 1) S'"
define P1' where "P1' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_row A - 1)) (0⇩m (dim_row A - 1) 1) P1"
define P2' where "P2' = four_block_mat P2 (0⇩m 2 (dim_row A - 2)) (0⇩m (dim_row A - 2) 2) (1⇩m (dim_row A - 2))"
define P3' where "P3' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_row A - 1)) (0⇩m (dim_row A - 1) 1) P3"
define Q3' where "Q3' = four_block_mat (1⇩m 1) (0⇩m 1 (dim_col A - 1)) (0⇩m (dim_col A - 1) 1) Q3"
have Smith_final: "Smith_mxn A = (P3' * P_H2 * P2' * P1', S, Q1 * Q2 * Q3')"
proof -
have P1_def: "P1 = fst (Smith_mxn A2)" and D1_def: "D1 = fst (snd (Smith_mxn A2))"
and Q1_def: "Q1 = snd (snd (Smith_mxn A2))" using P1D1Q1 by (metis fstI sndI)+
have P2_def: "P2 = fst (Smith_2xn D)" and F_def: "F = fst (snd (Smith_2xn D))"
and Q2_def: "Q2 = snd (snd (Smith_2xn D))" using P2FQ2 by (metis fstI sndI)+
have P_H2_def: "P_H2 = fst (reduce_column div_op H)"
and H2_def: "H2 = snd (reduce_column div_op H)"
using P_H2H2 by (metis fstI sndI)+
have H2_UL_def: "H2_UL = fst (split_block H2 1 1)"
and H2_UR_def: "H2_UR = fst (snd (split_block H2 1 1))"
and H2_DL_def: "H2_DL = fst (snd (snd (split_block H2 1 1)))"
and H2_DR_def: "H2_DR = snd (snd (snd (split_block H2 1 1)))"
using split_H2 by (metis fstI sndI)+
have P3_def: "P3 = fst (Smith_mxn H2_DR)" and S'_def: "S' = fst (snd (Smith_mxn H2_DR))"
and Q3_def: "Q3 = (snd (snd (Smith_mxn H2_DR)))" using P3S'Q3 by (metis fstI sndI)+
note aux = Smith_mxn.simps[of A] Let_def split_beta
A1_def[symmetric] A2_def[symmetric] P1_def[symmetric] D1_def[symmetric] Q1_def[symmetric]
C_def[symmetric] D_def[symmetric] E_def[symmetric] P2_def[symmetric] Q2_def[symmetric]
F_def[symmetric] H_def[symmetric] P_H2_def[symmetric] H2_def[symmetric] H2_UL_def[symmetric]
H2_DL_def[symmetric] H2_UR_def[symmetric] H2_DR_def[symmetric] P3_def[symmetric] S'_def[symmetric]
Q3_def[symmetric] P1'_def[symmetric] P2'_def[symmetric] P3'_def[symmetric] Q1_def[symmetric]
Q2_def[symmetric] Q3'_def[symmetric] S_def[symmetric]
show ?thesis by (rule prod3_intro, unfold aux, insert "1.prems", auto)
qed
show ?case
proof (unfold Smith_final, rule is_SNF_intro)
have A1[simp]: "A1 ∈ carrier_mat 1 n" unfolding A1_def using A by auto
have A2[simp]: "A2 ∈ carrier_mat (m-1) n" unfolding A2_def using A by auto
have is_SNF_A2: "is_SNF A2 (Smith_mxn A2)"
proof (cases "n ≤ 2 ∨ m - 1 ≤ 2")
case True
then show ?thesis using is_SNF_Smith_mxn_less_2[OF A2] by simp
next
case False
hence n1: "2<n" and m1: "2<m-1" by auto
show ?thesis by (rule "1.hyps"(1)[OF A_dim_intro A1_def A2_def A2 m1 n1])
qed
have P1[simp]: "P1 ∈ carrier_mat (m-1) (m-1)"
and inv_P1: "invertible_mat P1"
and Q1: "Q1 ∈ carrier_mat n n" and inv_Q1: "invertible_mat Q1"
and SNF_P1A2Q1: "Smith_normal_form_mat (P1*A2*Q1)"
using is_SNF_A2 P1D1Q1 A2 A n m unfolding is_SNF_def by auto
have C[simp]: "C ∈ carrier_mat m n" unfolding C_def using P1 Q1 A1 A2 m
by (smt "1"(3) A_dim_not0 Suc_pred card_num_simps(30) carrier_append_rows carrier_matD
carrier_mat_triv index_mult_mat(2,3) neq0_conv plus_1_eq_Suc)
have D[simp]: "D ∈ carrier_mat 2 n" unfolding D_def using A m by auto
have is_SNF_D: "is_SNF D (Smith_2xn D)" by (rule is_SNF_Smith_2xn[OF D])
hence P2[simp]: "P2 ∈ carrier_mat 2 2" and inv_P2: "invertible_mat P2"
and Q2[simp]: "Q2 ∈ carrier_mat n n" and inv_Q2: "invertible_mat Q2"
and F[simp]: "F ∈ carrier_mat 2 n" and F_P2DQ2: "F = P2*D*Q2"
and SNF_F: "Smith_normal_form_mat F"
using P2FQ2 D_def A unfolding is_SNF_def by auto
have E[simp]: "E ∈ carrier_mat (m-2) n" unfolding E_def using A by auto
have H_aux: "H ∈ carrier_mat (2 + (m-2)) n" unfolding H_def
by (rule carrier_append_rows, insert P2 D Q2 E F_P2DQ2 F A m n mult_carrier_mat, force)
hence H[simp]: "H ∈ carrier_mat m n" using m by auto
have H2[simp]: "H2 ∈ carrier_mat m n" using m H P_H2H2 A reduce_column by blast
have H2_DR[simp]: "H2_DR ∈ carrier_mat (m - 1) (n - 1)"
by (rule split_block(4)[OF split_H2[symmetric]], insert H2 m n A H, auto, insert H2, blast+)
have P1'[simp]: "P1' ∈ carrier_mat m m" unfolding P1'_def using P1 m by auto
have P2'[simp]: "P2' ∈ carrier_mat m m" unfolding P2'_def using P2 m A m
by (metis (no_types, lifting) H H_aux carrier_matD carrier_mat_triv
index_mat_four_block(2,3) index_one_mat(2,3))
have is_SNF_H2_DR: "is_SNF H2_DR (Smith_mxn H2_DR)"
proof (cases "2 < m - 1 ∧ 2 < n - 1")
case True
hence m1: "2<m-1" and n1: "2<n-1" by simp+
show ?thesis
by (rule "1.hyps"(2)[OF A_dim_intro A1_def A2_def P1D1Q1 _ _ C_def D_def E_def P2FQ2 _ _ H_def
P_H2H2 _ split_H2 _ _ _ H2_DR m1 n1], auto)
next
case False
hence "m-1≤2 ∨ n-1≤2" by auto
then show ?thesis using H2_DR is_SNF_Smith_mxn_less_2 by blast
qed
hence P3[simp]: "P3 ∈ carrier_mat (m-1) (m-1)" and inv_P3: "invertible_mat P3"
and Q3[simp]: "Q3 ∈ carrier_mat (n-1) (n-1)" and inv_Q3: "invertible_mat Q3"
and S'[simp]: "S' ∈ carrier_mat (m-1) (n-1)" and S'_P3H2_DRQ3: "S' = P3 * H2_DR * Q3"
and SNF_S': "Smith_normal_form_mat S'"
using A m n H2_DR P3S'Q3 unfolding is_SNF_def by auto
have P3'[simp]: "P3' ∈ carrier_mat m m" unfolding P3'_def using P3 m by auto
have P_H2[simp]: "P_H2 ∈ carrier_mat m m" using reduce_column[OF H P_H2H2] m by simp
have S[simp]: "S ∈ carrier_mat m n" unfolding S_def using H A S'
by (smt A_dim_intro(1) One_nat_def Suc_pred carrier_matD carrier_matI dim_col_mat(1)
dim_row_mat(1) index_mat_four_block(2,3) nat_neq_iff not_less_zero plus_1_eq_Suc)
have Q3'[simp]: "Q3' ∈ carrier_mat n n" unfolding Q3'_def using Q3 n by auto
show P_final_carrier: "P3' * P_H2 * P2' * P1' ∈ carrier_mat (dim_row A) (dim_row A)"
using P3' P_H2 P2' P1' A by (metis carrier_matD carrier_matI index_mult_mat(2,3))
show Q_final_carrier: "Q1 * Q2 * Q3' ∈ carrier_mat (dim_col A) (dim_col A)"
using Q1 Q2 Q3' A by (metis carrier_matD carrier_matI index_mult_mat(2,3))
have inv_P1': "invertible_mat P1'" unfolding P1'_def
by (rule invertible_mat_four_block_mat_lower_right[OF _ inv_P1], insert A P1, auto)
have inv_P2': "invertible_mat P2'" unfolding P2'_def
by (rule invertible_mat_four_block_mat_lower_right_id[OF _ _ _ _ _ inv_P2], insert A m, auto)
have inv_P3': "invertible_mat P3'" unfolding P3'_def
by (rule invertible_mat_four_block_mat_lower_right[OF _ inv_P3], insert A P3, auto)
have inv_P_H2: "invertible_mat P_H2" using reduce_column[OF H P_H2H2] m by simp
show "invertible_mat (P3' * P_H2 * P2' * P1')" using inv_P1' inv_P2' inv_P3' inv_P_H2
by (meson P1' P2' P3' P_H2 invertible_mult_JNF mult_carrier_mat)
have inv_Q3': "invertible_mat Q3'" unfolding Q3'_def
by (rule invertible_mat_four_block_mat_lower_right[OF _ inv_Q3], insert A Q3, auto)
show "invertible_mat (Q1 * Q2 * Q3')" using inv_Q1 inv_Q2 inv_Q3'
by (meson Q1 Q2 Q3' invertible_mult_JNF mult_carrier_mat)
have A_A1_A2: "A = A1 @⇩r A2" unfolding append_cols_def
proof (rule eq_matI)
have A1_A2': "A1 @⇩r A2 ∈ carrier_mat (1+(m-1)) n" by (rule carrier_append_rows[OF A1 A2])
hence A1_A2: "A1 @⇩r A2 ∈ carrier_mat m n" using m by simp
thus "dim_row A = dim_row (A1 @⇩r A2)" and "dim_col A = dim_col (A1 @⇩r A2)" using A by auto
fix i j assume i: "i < dim_row (A1 @⇩r A2)" and j: "j < dim_col (A1 @⇩r A2)"
show "A $$ (i, j) = (A1 @⇩r A2) $$ (i, j)"
proof (cases "i=0")
case True
have "(A1 @⇩r A2) $$ (i, j) = (A1 @⇩r A2) $$ (0, j)" using True by simp
also have "... = four_block_mat A1 (0⇩m (dim_row A1) 0) A2 (0⇩m (dim_row A2) 0) $$ (0,j)"
unfolding append_rows_def ..
also have "... = A1 $$ (0,j)" using A1 A1_A2 j by auto
also have "... = A $$ (0,j)" unfolding A1_def using A1_A2 A i j by auto
finally show ?thesis using True by simp
next
case False
let ?xs = "(map (Matrix.row A) [1..<dim_row A])"
have "(A1 @⇩r A2) $$ (i, j) = four_block_mat A1 (0⇩m (dim_row A1) 0) A2 (0⇩m (dim_row A2) 0) $$ (i,j)"
unfolding append_rows_def ..
also have "... = A2 $$ (i-1,j)" using A1 A1_A2' A2 False i j by auto
also have "... = mat_of_rows (dim_col A) ?xs $$ (i - 1, j)" by (simp add: A2_def)
also have "... = ?xs ! (i-1) $v j" by (rule mat_of_rows_index, insert i False A j m A1_A2, auto)
also have "... = A $$ (i,j)" using False A A1_A2 i j by auto
finally show ?thesis ..
qed
qed
have C_eq: "C = P1' * A * Q1"
proof -
have aux: "(A1 @⇩r A2) * Q1 = ((A1 * Q1) @⇩r (A2*Q1))"
by (rule append_rows_mult_right, insert A1 A2 Q1, auto)
have "P1' * A * Q1 = P1' * (A1 @⇩r A2) * Q1" using A_A1_A2 by simp
also have "... = P1' * ((A1 @⇩r A2) * Q1)" using A A_A1_A2 P1' Q1 assoc_mult_mat by blast
also have "... = P1' * ((A1 * Q1) @⇩r (A2*Q1))" by (simp add: aux)
also have "... = (A1 * Q1) @⇩r (P1 * (A2 * Q1))"
by (rule append_rows_mult_left_id, insert A1 Q1 A2 P1 P1'_def A, auto)
also have "... = (A1 * Q1) @⇩r (P1 * A2 * Q1)" using A2 P1 Q1 by auto
finally show ?thesis unfolding C_def ..
qed
have C_D_E: "C = D @⇩r E"
proof -
let ?xs = "[Matrix.row C 0, Matrix.row C 1]"
let ?ys = "(map (Matrix.row C) [0..<2])"
have xs_ys: "?xs = ?ys" by (simp add: upt_conv_Cons)
have D_rw: "D = mat_of_rows (dim_col C) (map (Matrix.row C) [0..<2])"
unfolding D_def xs_ys using A C by (metis carrier_matD(2))
have d1: "dim_col A = dim_col C" using A C by blast
have d2: "dim_row A = dim_row C" using A C by blast
show ?thesis unfolding D_rw E_def d1 d2 by (rule append_rows_split, insert m C A d2, auto)
qed
have H_eq: "H = P2' * P1' * A * Q1 * Q2"
proof -
have aux: "((P2 * D) @⇩r E) = P2' * (D @⇩r E)"
by (rule append_rows_mult_left_id2[symmetric, OF D E _ P2], insert P2'_def A, auto)
have "H = P2 * D * Q2 @⇩r E * Q2" by (simp add: H_def)
also have "... = (P2 * D @⇩r E) * Q2"
by (rule append_rows_mult_right[symmetric, OF mult_carrier_mat[OF P2 D] E Q2])
also have "... = P2' * (D @⇩r E) * Q2" by (simp add: aux)
also have "... = P2' * C * Q2" unfolding C_D_E by simp
also have "... = P2' * (P1' * A * Q1) * Q2" unfolding C_eq by simp
also have "... = P2' * P1' * A * Q1 * Q2"
by (smt A P1' P2' Q1 ‹P2' * C * Q2 = P2' * (P1' * A * Q1) * Q2› assoc_mult_mat mult_carrier_mat)
finally show ?thesis .
qed
have P_H2_H_H2: "P_H2 * H = H2" using reduce_column[OF H P_H2H2] m by auto
hence H2_eq: "H2 = P_H2 * P2' * P1' * A * Q1 * Q2" unfolding H_eq
by (smt P1' P1'_def P2' P2'_def P_H2 P_final_carrier Q1 Q2 Q_final_carrier assoc_mult_mat
carrier_matD carrier_mat_triv index_mult_mat(2,3))
have H2_as_four_block_mat: "H2 = four_block_mat H2_UL H2_UR H2_DL H2_DR"
using split_H2 by (metis (no_types, lifting) H2 P1' P1'_def Q3' Q3'_def carrier_matD
index_mat_four_block(2) index_one_mat(2) split_block(5))
have H2_UL: "H2_UL ∈ carrier_mat 1 1"
by (rule split_block(1)[OF split_H2[symmetric], of "m-1" "n-1"], insert H2 A m n, auto, insert H2, blast+)
have H2_UR: "H2_UR ∈ carrier_mat 1 (n-1)"
by (rule split_block(2)[OF split_H2[symmetric], of "m-1"], insert H2 A m n, auto, insert H2, blast+)
have H2_DL: "H2_DL ∈ carrier_mat (m-1) 1"
by (rule split_block(3)[OF split_H2[symmetric], of _ "n-1"], insert H2 A m n, auto, insert H2, blast+)
have H2_DR: "H2_DR ∈ carrier_mat (m-1) (n-1)"
by (rule split_block(4)[OF split_H2[symmetric], of _ "n-1"], insert H2 A m n, auto, insert H2, blast+)
have H_ij_F_ij: "H$$(i,j) = F $$(i,j)" if i: "i<2" and j: "j<n" for i j
proof -
have "H$$(i,j) = (if i < dim_row (P2*D*Q2) then (P2*D*Q2) $$ (i, j) else (E*Q2) $$ (i - 2, j))"
proof (unfold H_def, rule append_rows_nth)
show "P2 * D * Q2 ∈ carrier_mat 2 n" using F F_P2DQ2 by blast
show "E * Q2 ∈ carrier_mat (m-2) n" using E Q2 using mult_carrier_mat by blast
qed (insert m j i, auto)
also have "... = F $$ (i, j)" using F F_P2DQ2 i by auto
finally show ?thesis .
qed
have isDiagonal_F: "isDiagonal_mat F"
using is_SNF_D P2FQ2 unfolding is_SNF_def Smith_normal_form_mat_def by auto
have H_0j_0: "H $$ (0,j) = 0" if j: "j∈{1..<n}" for j
proof -
have "H $$ (0,j) = F $$ (0, j)" using H_ij_F_ij j by auto
also have "... = 0" using isDiagonal_F unfolding isDiagonal_mat_def using F j by auto
finally show ?thesis .
qed
have H2_0j: "H2 $$ (0,j) = H $$ (0,j)" if j: "j<n" for j
by (rule reduce_column_preserves2[OF H P_H2H2 _ _ _ j], insert m, auto)
have H2_UR_0: "H2_UR = (0⇩m 1 (n-1))"
proof (rule eq_matI)
show "dim_row H2_UR = dim_row (0⇩m 1 (n - 1))" and "dim_col H2_UR = dim_col (0⇩m 1 (n - 1))"
using H2_UR by auto
fix i j assume i: "i < dim_row (0⇩m 1 (n - 1))" and j: "j < dim_col (0⇩m 1 (n - 1))"
have i0: "i=0" using i by auto
have 1: "0 < dim_row H2_UL + dim_row H2_DR" using i H2_UL H2_DR by auto
have 2: "j+1 < dim_col H2_UL + dim_col H2_DR" using j H2_UL H2_DR by auto
have "H2_UR $$ (i, j) = H2 $$ (0,j+1)"
unfolding i0 H2_as_four_block_mat using index_mat_four_block(1)[OF 1 2] H2_UL by auto
also have "... = H $$ (0,j+1)" by (rule H2_0j, insert j, auto)
also have "... = 0" using H_0j_0 j by auto
finally show "H2_UR $$ (i, j) = 0⇩m 1 (n - 1) $$ (i, j)" using i j by auto
qed
have H2_UL00_H00: "H2_UL $$ (0,0) = H $$ (0,0)"
using H2_UL H2_as_four_block_mat H2_0j n by fastforce
have F00_dvd_Dij: "F$$(0,0) dvd D$$(i,j)" if i: "i<2" and j: "j<n" for i j
by (rule S00_dvd_all_A[OF D P2 Q2 inv_P2 inv_Q2 F_P2DQ2 SNF_F i j])
have D10_dvd_Eij: "D$$(1,0) dvd E$$(i,j)" if i: "i<m-2" and j: "j<n" for i j
proof -
have "D$$(1,0) = C$$(1,0)"
by (smt C C_D_E F F_P2DQ2 H H_def One_nat_def Suc_lessD add_diff_cancel_right' append_rows_def
arith_special(3) carrier_matD index_mat_four_block index_mult_mat(2) lessI m n plus_1_eq_Suc)
also have "... = (P1*A2*Q1) $$ (0,0)"
by (smt "1"(3) A1 A2 A_A1_A2 A_dim_not0 P1 Q1 Suc_eq_plus1 Suc_lessD add_diff_cancel_right'
append_rows_def arith_special(3) card_num_simps(30) carrier_matD index_mat_four_block
index_mult_mat(2,3) less_not_refl2 local.C_def m neq0_conv)
also have " ... dvd (P1*A2*Q1) $$ (i+1,j)"
by (rule SNF_first_divides_all[OF SNF_P1A2Q1 _ _ j], insert P1 A2 Q1 i A, auto)
also have "... = C $$ (i+2,j)" unfolding C_def using append_rows_nth
by (smt A A1 A2 A_A1_A2 P1 Q1 Suc_lessD add_Suc_right add_diff_cancel_left' append_rows_def
arith_special(3) carrier_matD index_mat_four_block index_mult_mat(2,3) j less_diff_conv
not_add_less2 plus_1_eq_Suc that(1))
also have "... = E$$(i,j)"
by (smt C C_D_E D add_diff_cancel_right' append_rows_def carrier_matD index_mat_four_block j i
less_diff_conv not_add_less2)
finally show ?thesis .
qed
have F00_H00: "F $$ (0,0) = H $$ (0,0)" using H_ij_F_ij n by auto
have F00_dvd_Eij: "F$$(0,0) dvd E$$(i,j)" if i: "i<m-2" and j: "j<n" for i j
by (metis (no_types, lifting) A A_dim_not0 D10_dvd_Eij F00_dvd_Dij arith_special(3) carrier_matD(2)
dvd_trans j lessI neq0_conv plus_1_eq_Suc i)
have F00_dvd_EQ2ij: "F$$(0,0) dvd (E*Q2) $$ (i,j)" if i: "i<m-2" and j: "j<n" for i j
using dvd_elements_mult_matrix_right[OF E Q2] F00_dvd_Eij i j by auto
have H00_dvd_all: "H $$ (0, 0) dvd H $$ (i, j)" if i: "i<m" and j: "j<n" for i j
proof (cases "i<2")
case True
then show ?thesis by (metis F F00_H00 H_ij_F_ij SNF_F SNF_first_divides_all j)
next
case False
have "F $$ (0,0) dvd (E*Q2) $$ (i-2,j)" by (rule F00_dvd_EQ2ij, insert False i j, auto)
moreover have "H $$ (i, j) = (E*Q2) $$ (i-2,j)"
by (smt C C_D_E D F F_P2DQ2 False H_def append_rows_def carrier_matD i
index_mat_four_block index_mult_mat(2) j)
ultimately show ?thesis using F00_H00 by simp
qed
have H_00_dvd_H_i0: "H $$ (0, 0) dvd H $$ (i, 0)" if i: "i<m" for i
using H00_dvd_all[OF i] n by auto
have H2_DL_0: "H2_DL = (0⇩m (m - 1) 1)"
proof (rule eq_matI)
show "dim_row (H2_DL) = dim_row (0⇩m (m - 1) 1)"
and "dim_col (H2_DL) = dim_col (0⇩m (m - 1) 1)" using P3 H2_DL A by auto
fix i j assume i: "i < dim_row (0⇩m (m - 1) 1)" and j: "j < dim_col (0⇩m (m - 1) 1)"
have j0: "j=0" using j by auto
have "(H2_DL) $$ (i, j) = H2 $$ (i+1,0)"
using H2_UR H2_UR_0 n j0 H2 H2_UL H2_as_four_block_mat i by auto
also have "... = 0"
proof (cases "i=0")
case True
have "H2 $$ (1,0) = H $$ (1,0)" by (rule reduce_column_preserves2[OF H P_H2H2], insert m n, auto)
also have "... = F $$ (1,0)" by (rule H_ij_F_ij, insert n, auto)
also have "... = 0" using isDiagonal_F F n unfolding isDiagonal_mat_def by auto
finally show ?thesis by (simp add: True)
next
case False
show ?thesis
proof (rule reduce_column_works(1)[OF H P_H2H2])
show "H $$ (0, 0) dvd H $$ (i + 1, 0)" using H_00_dvd_H_i0 False i by simp
show "∀j∈{1..<n}. H $$ (0, j) = 0" using H_0j_0 by auto
show "i + 1 ∈ {2..<m}" using i False by auto
qed (insert m n id, auto)
qed
finally show "(H2_DL) $$ (i, j) = 0⇩m (m - 1) 1 $$ (i, j)" using i j j0 by auto
qed
have "P3'*H2 = four_block_mat H2_UL H2_UR (P3 * H2_DL) (P3 * H2_DR)"
proof -
have "P3'*H2 = four_block_mat
(1⇩m 1 * H2_UL + 0⇩m 1 (dim_row A - 1) * H2_DL) (1⇩m 1 * H2_UR + 0⇩m 1 (dim_row A - 1) * H2_DR)
(0⇩m (dim_row A - 1) 1 * H2_UL + P3 * H2_DL) (0⇩m (dim_row A - 1) 1 * H2_UR + P3 * H2_DR)"
unfolding P3'_def H2_as_four_block_mat
by (rule mult_four_block_mat[OF _ _ _ P3 H2_UL H2_UR H2_DL H2_DR], insert A, auto)
also have "... = four_block_mat H2_UL H2_UR (P3 * H2_DL) (P3 * H2_DR)"
by (rule cong_four_block_mat, insert H2_UL A m H2_DL H2_DR H2_UR P3, auto)
finally show ?thesis .
qed
hence P3'_H2_as_four_block_mat: "P3'*H2 = four_block_mat H2_UL (0⇩m 1 (n-1)) (0⇩m (m - 1) 1) (P3 * H2_DR)"
unfolding H2_UR_0 H2_DL_0 using P3 by auto
also have "... * Q3' = S" (is "?lhs = ?rhs")
proof -
have "?lhs = four_block_mat H2_UL (0⇩m 1 (n-1)) (0⇩m (m - 1) 1) (P3 * H2_DR)
* four_block_mat (1⇩m 1) (0⇩m 1 (n - 1)) (0⇩m (n - 1) 1) Q3" unfolding Q3'_def using A by auto
also have "... =
four_block_mat (H2_UL * 1⇩m 1 + (0⇩m 1 (n-1)) * 0⇩m (n - 1) 1) (H2_UL * 0⇩m 1 (n - 1) + (0⇩m 1 (n-1)) * Q3)
(0⇩m (m - 1) 1 * 1⇩m 1 + P3 * H2_DR * 0⇩m (n - 1) 1) (0⇩m (m - 1) 1 * 0⇩m 1 (n - 1) + P3 * H2_DR * Q3)"
by (rule mult_four_block_mat[OF H2_UL], insert P3 H2_DR Q3, auto)
also have "... = four_block_mat H2_UL (0⇩m 1 (n - 1)) (0⇩m (m - 1) 1) (P3 * H2_DR * Q3)"
by (rule cong_four_block_mat, insert H2_UL A m H2_DL H2_DR H2_UR P3 Q3, auto)
also have "... = four_block_mat (Matrix.mat 1 1 (λ(a, b). H $$ (0, 0)))
(0⇩m 1 (dim_col A - 1)) (0⇩m (dim_row A - 1) 1) S'"
by (rule cong_four_block_mat, insert A S'_P3H2_DRQ3 H2_UL00_H00 H2_UL, auto)
finally show ?thesis unfolding S_def by simp
qed
finally have P3'_H2_Q3'_S: "P3'*H2*Q3' = S" .
have S_as_four_block_mat: "S = four_block_mat H2_UL (0⇩m 1 (n - 1)) (0⇩m (m - 1) 1) S'"
unfolding S_def by (rule cong_four_block_mat, insert A S'_P3H2_DRQ3 H2_UL00_H00 H2_UL, auto)
show "S = P3' * P_H2 * P2' * P1' * A * (Q1 * Q2 * Q3')" using P3'_H2_Q3'_S unfolding H2_eq
by (smt P1 P1'_def P2' P2'_def P3 P3'_def P_H2 Q1 Q2 Q3' Q3'_def S Q_final_carrier P_final_carrier
assoc_mult_mat carrier_matD carrier_mat_triv index_mat_four_block(2,3) index_mult_mat(2,3))
have H00_dvd_all_H2: "H $$ (0, 0) dvd H2 $$ (i, j)" if i: "i<m" and j: "j<n" for i j
using dvd_elements_mult_matrix_left[OF H P_H2] H00_dvd_all i j P_H2_H_H2 by blast
hence H00_dvd_all_S: "H $$ (0, 0) dvd S $$ (i, j)" if i: "i<m" and j: "j<n" for i j
using dvd_elements_mult_matrix_left_right[OF H2 P3' Q3'] P3'_H2_Q3'_S i j by auto
show "Smith_normal_form_mat S"
proof (rule Smith_normal_form_mat_intro)
show "isDiagonal_mat S"
proof (unfold isDiagonal_mat_def, rule+)
fix i j assume "i ≠ j ∧ i < dim_row S ∧ j < dim_col S"
hence ij: "i ≠ j" and i: "i < dim_row S" and j: "j < dim_col S" by auto
have i2: "i < dim_row H2_UL + dim_row S'" and j2: "j < dim_col H2_UL + dim_col S'"
using S_as_four_block_mat i j by auto
have "S $$ (i,j) = (if i < dim_row H2_UL then if j < dim_col H2_UL then H2_UL $$ (i, j)
else (0⇩m 1 (n - 1)) $$ (i, j - dim_col H2_UL) else if j < dim_col H2_UL
then (0⇩m (m - 1) 1) $$ (i - dim_row H2_UL, j) else S' $$ (i - dim_row H2_UL, j - dim_col H2_UL))"
by (unfold S_as_four_block_mat, rule index_mat_four_block(1)[OF i2 j2])
also have "... = 0" (is "?lhs = 0")
proof (cases "i = 0 ∨ j = 0")
case True
then show ?thesis unfolding S_def using ij i j S H2_UL by fastforce
next
case False
have diag_S': "isDiagonal_mat S'" using SNF_S' unfolding Smith_normal_form_mat_def by simp
have i_not_0: "i≠0" and j_not_0: "j≠0" using False by auto
hence "?lhs = S' $$ (i - dim_row H2_UL, j - dim_col H2_UL)" using i j ij H2_UL by auto
also have "... = 0" using diag_S' S' H2_UL i_not_0 j_not_0 ij unfolding isDiagonal_mat_def
by (smt S_as_four_block_mat add_diff_inverse_nat add_less_cancel_left carrier_matD i
index_mat_four_block(2,3) j less_one)
finally show ?thesis .
qed
finally show "S $$ (i, j) = 0" .
qed
show "∀a. a + 1 < min (dim_row S) (dim_col S) ⟶ S $$ (a, a) dvd S $$ (a + 1, a + 1)"
proof safe
fix i assume i: "i + 1 < min (dim_row S) (dim_col S)"
show "S $$ (i, i) dvd S $$ (i + 1, i + 1)"
proof (cases "i=0")
case True
have "S $$ (0, 0) = H $$ (0,0)" using H2_UL H2_UL00_H00 S_as_four_block_mat by auto
also have "... dvd S $$ (1,1)" using H00_dvd_all_S i m n by auto
finally show ?thesis using True by simp
next
case False
have "S $$ (i, i)= S' $$ (i-1, i-1)" using False S_def i by auto
also have "... dvd S' $$ (i, i)" using SNF_S' i S' S unfolding Smith_normal_form_mat_def
by (smt False H2_UL S_as_four_block_mat add.commute add_diff_inverse_nat carrier_matD
index_mat_four_block(2,3) less_one min_less_iff_conj nat_add_left_cancel_less)
also have "... = S $$ (i+1,i+1)" using False S_def i by auto
finally show ?thesis .
qed
qed
qed
qed
qed
subsection ‹Soundness theorem›
theorem is_SNF_Smith_mxn:
assumes A: "A ∈ carrier_mat m n"
shows "is_SNF A (Smith_mxn A)"
using is_SNF_Smith_mxn_ge_2[OF A] is_SNF_Smith_mxn_less_2[OF A] by linarith
declare Smith_mxn.simps[code]
end
declare Smith_Impl.Smith_mxn.simps[code_unfold]
definition T_spec :: "('a::{comm_ring_1} ⇒ 'a ⇒ ('a × 'a × 'a)) ⇒ bool"
where "T_spec T = (∀a b::'a. let (a1,b1,d) = T a b in
a = a1*d ∧ b = b1*d ∧ ideal_generated {a1,b1} = ideal_generated {1})"
definition D'_spec :: "('a::{comm_ring_1} ⇒ 'a ⇒ 'a ⇒ ('a × 'a)) ⇒ bool"
where "D'_spec D' = (∀a b c::'a. let (p,q) = D' a b c in
ideal_generated{a,b,c} = ideal_generated{1}
⟶ ideal_generated {p*a,p*b+q*c} = ideal_generated {1})"
end
Theory SNF_Algorithm_HOL_Analysis
section ‹The Smith normal form algorithm in HOL Analysis›
theory SNF_Algorithm_HOL_Analysis
imports
SNF_Algorithm
Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin
subsection ‹Transferring the result from JNF to HOL Anaylsis›
definition Smith_mxn_HMA :: "(('a::comm_ring_1^2) ⇒ (('a^2) × ('a^2^2)))
⇒ (('a^2^2) ⇒ (('a^2^2) × ('a^2^2) × ('a^2^2))) ⇒ ('a⇒'a⇒'a) ⇒ ('a^'n::mod_type^'m::mod_type)
⇒ (('a^'m::mod_type^'m::mod_type)× ('a^'n::mod_type^'m::mod_type) × ('a^'n::mod_type^'n::mod_type))"
where
"Smith_mxn_HMA Smith_1x2 Smith_2x2 div_op A =
(let Smith_1x2_JNF = (λA'. let (S',Q') = Smith_1x2 (Mod_Type_Connect.to_hma⇩v (Matrix.row A' 0))
in (mat_of_row (Mod_Type_Connect.from_hma⇩v S'), Mod_Type_Connect.from_hma⇩m Q'));
Smith_2x2_JNF = (λA'. let (P', S',Q') = Smith_2x2 (Mod_Type_Connect.to_hma⇩m A')
in (Mod_Type_Connect.from_hma⇩m P', Mod_Type_Connect.from_hma⇩m S', Mod_Type_Connect.from_hma⇩m Q'));
(P,S,Q) = Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op (Mod_Type_Connect.from_hma⇩m A)
in (Mod_Type_Connect.to_hma⇩m P, Mod_Type_Connect.to_hma⇩m S, Mod_Type_Connect.to_hma⇩m Q)
)"
definition "is_SNF_HMA A R = (case R of (P,S,Q) ⇒
invertible P ∧ invertible Q
∧ Smith_normal_form S ∧ S = P ** A ** Q)"
subsection ‹Soundness in HOL Anaylsis›
lemma is_SNF_Smith_mxn_HMA:
fixes A::"'a::comm_ring_1 ^ 'n::mod_type ^ 'm::mod_type"
assumes PSQ: "(P,S,Q) = Smith_mxn_HMA Smith_1x2 Smith_2x2 div_op A"
and SNF_1x2_works: "∀A. let (S',Q) = Smith_1x2 A in S' $h 1 = 0 ∧ invertible Q ∧ S' = A v* Q"
and SNF_2x2_works: "∀A. is_SNF_HMA A (Smith_2x2 A)"
and d: "is_div_op div_op"
shows "is_SNF_HMA A (P,S,Q)"
proof -
let ?A = "Mod_Type_Connect.from_hma⇩m A"
define Smith_1x2_JNF where "Smith_1x2_JNF = (λA'. let (S',Q')
= Smith_1x2 (Mod_Type_Connect.to_hma⇩v (Matrix.row A' 0))
in (mat_of_row (Mod_Type_Connect.from_hma⇩v S'), Mod_Type_Connect.from_hma⇩m Q'))"
define Smith_2x2_JNF where "Smith_2x2_JNF = (λA'. let (P', S',Q') = Smith_2x2 (Mod_Type_Connect.to_hma⇩m A')
in (Mod_Type_Connect.from_hma⇩m P', Mod_Type_Connect.from_hma⇩m S', Mod_Type_Connect.from_hma⇩m Q'))"
obtain P' S' Q' where P'S'Q': "(P',S',Q') = Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op ?A"
by (metis prod_cases3)
have PSQ_P'S'Q': "(P,S,Q) =
(Mod_Type_Connect.to_hma⇩m P', Mod_Type_Connect.to_hma⇩m S', Mod_Type_Connect.to_hma⇩m Q')"
using PSQ P'S'Q' Smith_1x2_JNF_def Smith_2x2_JNF_def
unfolding Smith_mxn_HMA_def Let_def by (metis case_prod_conv)
have SNF_1x2_works': "∀(A::'a mat) ∈ carrier_mat 1 2. is_SNF A (1⇩m 1, (Smith_1x2_JNF A))"
proof (rule+)
fix A'::"'a mat" assume A': "A' ∈ carrier_mat 1 2"
let ?A' = "(Mod_Type_Connect.to_hma⇩v (Matrix.row A' 0))::'a^2"
obtain S2 Q2 where S'Q': "(S2,Q2) = Smith_1x2 ?A'"
by (metis surjective_pairing)
let ?S2 = "(Mod_Type_Connect.from_hma⇩v S2)"
let ?S' = "mat_of_row ?S2"
let ?Q' = "Mod_Type_Connect.from_hma⇩m Q2"
have [transfer_rule]: "Mod_Type_Connect.HMA_V ?S2 S2"
unfolding Mod_Type_Connect.HMA_V_def by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q' Q2"
unfolding Mod_Type_Connect.HMA_M_def by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_I 1 (1::2)"
unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_1)
have c[transfer_rule]: "Mod_Type_Connect.HMA_V ((Matrix.row A' 0)) ?A'"
unfolding Mod_Type_Connect.HMA_V_def
by (rule from_hma_to_hma⇩v[symmetric], insert A', auto simp add: Matrix.row_def)
have *: "Smith_1x2_JNF A' = (?S', ?Q')" by (metis Smith_1x2_JNF_def S'Q' case_prod_conv)
show "is_SNF A' (1⇩m 1, Smith_1x2_JNF A')" unfolding *
proof (rule is_SNF_intro)
let ?row_A' = "(Matrix.row A' 0)"
have w: "S2 $h 1 = 0 ∧ invertible Q2 ∧ S2 = ?A' v* Q2"
using SNF_1x2_works by (metis (mono_tags, lifting) S'Q' fst_conv prod.case_eq_if snd_conv)
have "?S2 $v 1 = 0" using w[untransferred] by auto
thus "Smith_normal_form_mat ?S'" unfolding Smith_normal_form_mat_def isDiagonal_mat_def
by (auto simp add: less_2_cases_iff)
have S2_Q2_A: "S2 = transpose Q2 *v ?A'" using w transpose_matrix_vector by auto
have S2_Q2_A': "?S2 = transpose_mat ?Q' *⇩v ((Matrix.row A' 0))" using S2_Q2_A by transfer'
show "1⇩m 1 ∈ carrier_mat (dim_row A') (dim_row A')" using A' by auto
show "?Q' ∈ carrier_mat (dim_col A') (dim_col A')" using A' by auto
show "invertible_mat (1⇩m 1)" by auto
show "invertible_mat ?Q'" using w[untransferred] by auto
have "?S' = A' * ?Q'"
proof (rule eq_matI)
show "dim_row ?S' = dim_row (A' * ?Q')" and "dim_col ?S' = dim_col (A' * ?Q')"
using A' by auto
fix i j assume i: "i < dim_row (A' * ?Q')" and j: "j < dim_col (A' * ?Q')"
have "?S' $$ (i, j) = ?S' $$ (0, j)"
by (metis A' One_nat_def carrier_matD(1) i index_mult_mat(2) less_Suc0)
also have "... =?S2 $v j" using j by auto
also have "... = (transpose_mat ?Q' *⇩v ?row_A') $v j" unfolding S2_Q2_A' by simp
also have "... = Matrix.row (transpose_mat ?Q') j ∙ ?row_A'"
by (rule index_mult_mat_vec, insert j, auto)
also have "... = Matrix.col ?Q' j ∙ ?row_A'" using j by auto
also have "... = ?row_A' ∙ Matrix.col ?Q' j"
by (metis (no_types, lifting) Mod_Type_Connect.HMA_V_def Mod_Type_Connect.from_hma⇩m_def
Mod_Type_Connect.from_hma⇩v_def c col_def comm_scalar_prod dim_row_mat(1) vec_carrier)
also have "... = (A' * ?Q') $$ (0, j)" using A' j by auto
finally show "?S' $$ (i, j) = (A' * ?Q') $$ (i, j)" using i j A' by auto
qed
thus "?S' = 1⇩m 1 * A' * ?Q'" using A' by auto
qed
qed
have SNF_2x2_works': "∀(A::'a mat) ∈ carrier_mat 2 2. is_SNF A (Smith_2x2_JNF A)"
proof
fix A'::"'a mat" assume A': "A' ∈ carrier_mat 2 2"
let ?A' = "Mod_Type_Connect.to_hma⇩m A'::'a^2^2"
obtain P2 S2 Q2 where P2S2Q2: "(P2, S2, Q2) = Smith_2x2 ?A'"
by (metis prod_cases3)
let ?P2 = "Mod_Type_Connect.from_hma⇩m P2"
let ?S2 = "Mod_Type_Connect.from_hma⇩m S2"
let ?Q2 = "Mod_Type_Connect.from_hma⇩m Q2"
have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q2 Q2"
and [transfer_rule]: "Mod_Type_Connect.HMA_M ?P2 P2"
and [transfer_rule]: "Mod_Type_Connect.HMA_M ?S2 S2"
and [transfer_rule]: "Mod_Type_Connect.HMA_M A' ?A'"
unfolding Mod_Type_Connect.HMA_M_def using A' by auto
have "is_SNF A' (?P2,?S2,?Q2)"
proof -
have P2: "?P2 ∈ carrier_mat (dim_row A') (dim_row A')" and
Q2: "?Q2 ∈ carrier_mat (dim_col A') (dim_col A')" using A' by auto
have "is_SNF_HMA ?A' (P2,S2,Q2)" using SNF_2x2_works by (simp add: P2S2Q2)
hence "invertible P2 ∧ invertible Q2 ∧ Smith_normal_form S2 ∧ S2 = P2 ** ?A' ** Q2"
unfolding is_SNF_HMA_def by auto
from this[untransferred] show ?thesis using P2 Q2 unfolding is_SNF_def by auto
qed
thus "is_SNF A' (Smith_2x2_JNF A')" using P2S2Q2 by (metis Smith_2x2_JNF_def case_prod_conv)
qed
interpret Smith_Impl Smith_1x2_JNF Smith_2x2_JNF div_op
using SNF_2x2_works' SNF_1x2_works' d by (unfold_locales, auto)
have A: "?A ∈ carrier_mat CARD('m) CARD('n)" by auto
have "is_SNF ?A (Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op ?A)"
by (rule is_SNF_Smith_mxn[OF A])
hence inv_P': "invertible_mat P'"
and Smith_S': "Smith_normal_form_mat S'" and inv_Q': "invertible_mat Q'"
and S'_P'AQ': "S' = P' * ?A * Q'"
and P': "P' ∈ carrier_mat (dim_row ?A) (dim_row ?A)"
and Q': "Q' ∈ carrier_mat (dim_col ?A) (dim_col ?A)"
unfolding is_SNF_def P'S'Q'[symmetric] by auto
have S': "S' ∈ carrier_mat (dim_row ?A) (dim_col ?A)" using P' Q' S'_P'AQ' by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_M P' P"
and [transfer_rule]: "Mod_Type_Connect.HMA_M S' S"
and [transfer_rule]: "Mod_Type_Connect.HMA_M Q' Q"
and [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A"
unfolding Mod_Type_Connect.HMA_M_def using PSQ_P'S'Q'
using from_hma_to_hma⇩m[symmetric] P' A Q' S' by auto
have inv_Q: "invertible Q" using inv_Q' by transfer
moreover have Smith_S: "Smith_normal_form S" using Smith_S' by transfer
moreover have inv_P: "invertible P" using inv_P' by transfer
moreover have "S = P ** A ** Q" using S'_P'AQ' by transfer
thus ?thesis using inv_Q inv_P Smith_S unfolding is_SNF_HMA_def by auto
qed
end
Theory Elementary_Divisor_Rings
section ‹Elementary divisor rings›
theory Elementary_Divisor_Rings
imports
SNF_Algorithm
Rings2_Extended
begin
text ‹This theory contains the definition of elementary divisor rings and Hermite rings, as
well as the corresponding relation between both concepts.
It also includes a complete characterization
for elementary divisor rings, by means of an \emph{if and only if}-statement.
The results presented here follows the article ``Some remarks about elementary divisor rings''
by Leonard Gillman and Melvin Henriksen.›
subsection ‹Previous definitions and basic properties of Hermite ring›
definition "admits_triangular_reduction A =
(∃U::'a::comm_ring_1 mat. U ∈ carrier_mat (dim_col A) (dim_col A)
∧ invertible_mat U ∧ lower_triangular (A*U))"
class Hermite_ring =
assumes "∀(A::'a::comm_ring_1 mat). admits_triangular_reduction A"
lemma admits_triangular_reduction_intro:
assumes "invertible_mat (U::'a::comm_ring_1 mat)"
and "U ∈ carrier_mat (dim_col A) (dim_col A)"
and "lower_triangular (A*U)"
shows "admits_triangular_reduction A"
using assms unfolding admits_triangular_reduction_def by auto
lemma OFCLASS_Hermite_ring_def:
"OFCLASS('a::comm_ring_1, Hermite_ring_class)
≡ (⋀(A::'a::comm_ring_1 mat). admits_triangular_reduction A)"
proof
fix A::"'a mat"
assume H: "OFCLASS('a::comm_ring_1, Hermite_ring_class)"
have "∀A. admits_triangular_reduction (A::'a mat)"
using conjunctionD2[OF H[unfolded Hermite_ring_class_def class.Hermite_ring_def]] by auto
thus "admits_triangular_reduction A" by auto
next
assume i: "(⋀A::'a mat. admits_triangular_reduction A)"
show "OFCLASS('a, Hermite_ring_class)"
proof
show "∀A::'a mat. admits_triangular_reduction A" using i by auto
qed
qed
definition admits_diagonal_reduction::"'a::comm_ring_1 mat ⇒ bool"
where "admits_diagonal_reduction A = (∃P Q. P ∈ carrier_mat (dim_row A) (dim_row A) ∧
Q ∈ carrier_mat (dim_col A) (dim_col A)
∧ invertible_mat P ∧ invertible_mat Q
∧ Smith_normal_form_mat (P * A * Q))"
lemma admits_diagonal_reduction_intro:
assumes "P ∈ carrier_mat (dim_row A) (dim_row A)"
and "Q ∈ carrier_mat (dim_col A) (dim_col A)"
and "invertible_mat P" and "invertible_mat Q "
and "Smith_normal_form_mat (P * A * Q)"
shows "admits_diagonal_reduction A" using assms unfolding admits_diagonal_reduction_def by fast
lemma admits_diagonal_reduction_imp_exists_algorithm_is_SNF:
assumes "A ∈ carrier_mat m n"
and "admits_diagonal_reduction A"
shows "∃algorithm. is_SNF A (algorithm A)"
using assms unfolding is_SNF_def admits_diagonal_reduction_def
by auto
lemma exists_algorithm_is_SNF_imp_admits_diagonal_reduction:
assumes "A ∈ carrier_mat m n"
and "∃algorithm. is_SNF A (algorithm A)"
shows "admits_diagonal_reduction A"
using assms unfolding is_SNF_def admits_diagonal_reduction_def
by auto
lemma admits_diagonal_reduction_eq_exists_algorithm_is_SNF:
assumes A: "A ∈ carrier_mat m n"
shows "admits_diagonal_reduction A = (∃algorithm. is_SNF A (algorithm A))"
using admits_diagonal_reduction_imp_exists_algorithm_is_SNF[OF A]
using exists_algorithm_is_SNF_imp_admits_diagonal_reduction[OF A]
by auto
lemma admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all:
assumes "(∀(A::'a::comm_ring_1 mat) ∈ carrier_mat m n. admits_diagonal_reduction A)"
shows" (∃algorithm. ∀(A::'a mat) ∈ carrier_mat m n. is_SNF A (algorithm A))"
proof -
let ?algorithm = "λA. SOME (P, S, Q). is_SNF A (P,S,Q)"
show ?thesis
by (rule exI[of _ ?algorithm]) (metis (no_types, lifting)
admits_diagonal_reduction_imp_exists_algorithm_is_SNF assms case_prod_beta prod.collapse someI)
qed
lemma exists_algorithm_is_SNF_imp_admits_diagonal_reduction_all:
assumes "(∃algorithm. ∀(A::'a mat) ∈ carrier_mat m n. is_SNF A (algorithm A))"
shows "(∀(A::'a::comm_ring_1 mat) ∈ carrier_mat m n. admits_diagonal_reduction A)"
using assms exists_algorithm_is_SNF_imp_admits_diagonal_reduction by blast
lemma admits_diagonal_reduction_eq_exists_algorithm_is_SNF_all:
shows "(∀(A::'a::comm_ring_1 mat) ∈ carrier_mat m n. admits_diagonal_reduction A)
= (∃algorithm. ∀(A::'a mat) ∈ carrier_mat m n. is_SNF A (algorithm A))"
using exists_algorithm_is_SNF_imp_admits_diagonal_reduction_all
using admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all by auto
subsection ‹The class that represents elementary divisor rings›
class elementary_divisor_ring =
assumes "∀(A::'a::comm_ring_1 mat). admits_diagonal_reduction A"
lemma dim_row_mat_diag[simp]: "dim_row (mat_diag n f) = n" and
dim_col_mat_diag[simp]: "dim_col (mat_diag n f) = n"
using mat_diag_dim unfolding carrier_mat_def by auto+
subsection ‹Hermite ring implies B\'ezout ring›
text ‹To prove this fact, we make use of the alternative definition for B\'ezout rings:
each finitely generated ideal is principal›
lemma Hermite_ring_imp_Bezout_ring:
assumes H: "OFCLASS('a::comm_ring_1, Hermite_ring_class)"
shows " OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule+)
fix I::"'a set" assume fin: "finitely_generated_ideal I"
obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S"
using fin unfolding finitely_generated_ideal_def by auto
obtain xs where set_xs: "set xs = S" and d: "distinct xs"
using finite_distinct_list[OF fin_S] by blast
hence length_eq_card: "length xs = card S" using distinct_card by force
define n where "n = card S"
define A where "A = mat_of_rows n [vec_of_list xs]"
have A[simp]: "A ∈ carrier_mat 1 n" unfolding A_def using mat_of_rows_carrier by auto
have "∀(A::'a::comm_ring_1 mat). admits_triangular_reduction A"
using H unfolding OFCLASS_Hermite_ring_def by auto
from this obtain Q where inv_Q: "invertible_mat Q" and t_AQ: "lower_triangular (A*Q)"
and Q[simp]: "Q ∈ carrier_mat n n"
unfolding admits_triangular_reduction_def using A by auto
have AQ[simp]: "A * Q ∈ carrier_mat 1 n" using A Q by auto
show "principal_ideal I"
proof (cases "xs=[]")
case True
then show ?thesis
by (metis empty_set ideal_generated_0 ideal_generated_empty ig_S principal_ideal_def set_xs)
next
case False
have a: "0 < dim_row A" using A by auto
have "0 < length xs" using False by auto
hence b: "0 < dim_col A" using A n_def length_eq_card by auto
have q0: "0 < dim_col Q" by (metis A Q b carrier_matD(2))
have n0: "0<n" using ‹0 < length xs› length_eq_card n_def by linarith
define d where "d = (A*Q) $$ (0,0)"
let ?h = "(λx. THE i. xs ! i = x ∧ i<n)"
let ?u = "λi. xs ! i"
have bij: "bij_betw ?h (set xs) {0..<n}"
proof (rule bij_betw_imageI)
show "inj_on ?h (set xs)"
proof -
have "x=y" if x: "x ∈ set xs" and y: "y ∈ set xs"
and xy: "(THE i. xs ! i = x ∧ i < n) = (THE i. xs ! i = y ∧ i < n)" for x y
proof -
let ?i = "(THE i. xs ! i = x ∧ i < n)"
let ?j = "(THE i. xs ! i = y ∧ i < n)"
obtain i where xs_i: "xs ! i = x ∧ i < n" using x
by (metis in_set_conv_nth length_eq_card n_def)
from this have 1: "xs ! ?i = x ∧ ?i < n"
by (rule theI, insert d xs_i length_eq_card n_def nth_eq_iff_index_eq, fastforce)
obtain j where xs_j: "xs ! j = y ∧ j < n" using y
by (metis in_set_conv_nth length_eq_card n_def)
from this have 2: "xs ! ?j = y ∧ ?j < n"
by (rule theI, insert d xs_j length_eq_card n_def nth_eq_iff_index_eq, fastforce)
show ?thesis using 1 2 d xy by argo
qed
thus ?thesis unfolding inj_on_def by auto
qed
show "(λx. THE i. xs ! i = x ∧ i < n) ` set xs = {0..<n}"
proof (auto)
fix xa assume xa: "xa ∈ set xs"
let ?i = "(THE i. xs ! i = xa ∧ i < n)"
obtain i where xs_i: "xs ! i = xa ∧ i < n" using xa
by (metis in_set_conv_nth length_eq_card n_def)
from this have 1: "xs ! ?i = xa ∧ ?i < n"
by (rule theI, insert d xs_i length_eq_card n_def nth_eq_iff_index_eq, fastforce)
thus "(THE i. xs ! i = xa ∧ i < n) < n" by simp
next
fix x assume x: "x<n"
have "∃xa∈set xs. x = (THE i. xs ! i = xa ∧ i < n)"
by (rule bexI[of _ "xs ! x"], rule the_equality[symmetric], insert x d)
(auto simp add: length_eq_card n_def nth_eq_iff_index_eq)+
thus "x ∈ (λx. THE i. xs ! i = x ∧ i < n) ` set xs" unfolding image_def by auto
qed
qed
have i: "ideal_generated {d} = ideal_generated S"
proof -
have ideal_S_explicit: "ideal_generated S = {y. ∃f. (∑i∈S. f i * i) = y}"
unfolding ideal_explicit2[OF fin_S] by simp
have "ideal_generated {d} ⊆ ideal_generated S"
proof (rule ideal_generated_subset2, auto simp add: ideal_S_explicit)
have n: "dim_vec (col Q 0) = n" using Q n_def by auto
have aux: "Matrix.row A 0 $v i = xs ! i" if i: "i<n" for i
proof -
have i2: "i < dim_col A"
by (simp add: A_def i)
have "Matrix.row A 0 $v i = A $$ (0,i)" by (rule index_row(1), auto simp add: a b i2)
also have "... = [vec_of_list xs] ! 0 $v i"
unfolding A_def by (rule mat_of_rows_index, auto simp add: i)
also have "... = xs ! i"
by (simp add: vec_of_list_index)
finally show ?thesis .
qed
let ?f = "λx. let i = (THE i. xs ! i = x ∧ i < n) in col Q 0 $v i"
let ?g = "(λi. xs ! i * col Q 0 $v i)"
have "d = (A*Q) $$ (0,0)" unfolding d_def by simp
also have "... = Matrix.row A 0 ∙ col Q 0" by (rule index_mult_mat(1)[OF a q0])
also have "... = (∑i = 0..<dim_vec (col Q 0). Matrix.row A 0 $v i * col Q 0 $v i)"
unfolding scalar_prod_def by simp
also have "... = (∑i = 0..<n. Matrix.row A 0 $v i * col Q 0 $v i)" unfolding n by auto
also have "... = (∑i = 0..<n. xs ! i * col Q 0 $v i)"
by (rule sum.cong, auto simp add: aux)
also have "... = (∑x ∈ set xs. ?g (?h x))"
by (rule sum.reindex_bij_betw[symmetric, OF bij])
also have "... = (∑x ∈ set xs. ?f x * x)"
proof (rule sum.cong, auto simp add: Let_def)
fix x assume x: "x ∈ set xs"
let ?i = "(THE i. xs ! i = x ∧ i < n)"
obtain i where xs_i: "xs ! i = x ∧ i < n"
by (metis in_set_conv_nth x length_eq_card n_def)
from this have "xs ! ?i = x ∧ ?i < n"
by (rule theI, insert d xs_i length_eq_card n_def nth_eq_iff_index_eq, fastforce)
thus "xs ! ?i * col Q 0 $v ?i = col Q 0 $v ?i * x" by auto
qed
also have "... = (∑x ∈ S. ?f x * x)" using set_xs by auto
finally show "∃f. (∑i∈S. f i * i) = d" by auto
qed
moreover have "ideal_generated S ⊆ ideal_generated {d}"
proof
fix x assume x: "x ∈ ideal_generated S" thm Matrix.diag_mat_def
hence x_xs: "x ∈ ideal_generated (set xs)" by (simp add: set_xs)
from this obtain f where f: "(∑i∈(set xs). f i * i) = x" using x ideal_explicit2 by auto
define B where "B = Matrix.vec n (λi. f (A $$ (0,i)))"
have B: "B ∈ carrier_vec n" unfolding B_def by auto
have "(A *⇩v B) $v 0 = Matrix.row A 0 ∙ B" by (rule index_mult_mat_vec[OF a])
also have "... = sum (λi. f (A $$ (0,i)) * A $$ (0,i)) {0..<n}"
unfolding B_def Matrix.row_def scalar_prod_def by (rule sum.cong, auto simp add: A_def)
also have "... = sum (λi. f i * i) (set xs)"
proof (rule sum.reindex_bij_betw)
have 1: "inj_on (λx. A $$ (0, x)) {0..<n}"
proof (unfold inj_on_def, auto)
fix x y assume x: "x < n" and y: "y < n" and xy: "A $$ (0, x) = A $$ (0, y)"
have "A $$ (0,x) = [vec_of_list xs] ! 0 $v x"
unfolding A_def by (rule mat_of_rows_index, insert x y, auto)
also have "... = xs ! x" using x by (simp add: vec_of_list_index)
finally have 1: "A $$ (0,x) = xs ! x" .
have "A $$ (0,y) = [vec_of_list xs] ! 0 $v y"
unfolding A_def by (rule mat_of_rows_index, insert x y, auto)
also have "... = xs ! y" using y by (simp add: vec_of_list_index)
finally have 2: "A $$ (0,y) = xs ! y" .
show "x = y" using 1 2 x y d length_eq_card n_def nth_eq_iff_index_eq xy by fastforce
qed
have 2: "A $$ (0, xa) ∈ set xs" if xa: "xa < n" for xa
proof -
have "A $$ (0,xa) = [vec_of_list xs] ! 0 $v xa"
unfolding A_def by (rule mat_of_rows_index, insert xa, auto)
also have "... = xs ! xa" using xa by (simp add: vec_of_list_index)
finally show ?thesis using xa by (simp add: length_eq_card n_def)
qed
have 3: "x ∈ (λx. A $$ (0, x)) ` {0..<n}" if x: "x∈ set xs" for x
proof -
obtain i where xs: "xs ! i = x ∧ i < n"
by (metis in_set_conv_nth length_eq_card n_def x)
have "A $$ (0,i) = [vec_of_list xs] ! 0 $v i"
unfolding A_def by (rule mat_of_rows_index, insert xs, auto)
also have "... = xs ! i" using xs by (simp add: vec_of_list_index)
finally show ?thesis using xs unfolding image_def by auto
qed
show "bij_betw (λx. A $$ (0, x)) {0..<n} (set xs)" using 1 2 3 unfolding bij_betw_def by auto
qed
finally have AB00_sum: "(A *⇩v B) $v 0 = sum (λi. f i * i) (set xs)" by auto
hence AB_00_x: "(A *⇩v B) $v 0 = x" using f by auto
obtain Q' where QQ': "inverts_mat Q Q'"
and Q'Q: "inverts_mat Q' Q" and Q': "Q' ∈ carrier_mat n n"
by (rule obtain_inverse_matrix[OF Q inv_Q], auto)
have eq: "A = (A*Q)*Q'" using QQ' unfolding inverts_mat_def
by (metis A Q Q' assoc_mult_mat carrier_matD(1) right_mult_one_mat)
let ?g = "λi. Matrix.row (A * Q) 0 $v i * (Matrix.row Q' i ∙ B)"
have sum0: "(∑i = 1..<n. ?g i) = 0"
proof (rule sum.neutral, rule)
fix x assume x: "x ∈ {1..<n}"
hence "Matrix.row (A * Q) 0 $v x = 0" using t_AQ unfolding lower_triangular_def
by (auto, metis Q Suc_le_lessD a carrier_matD(2) index_mult_mat(2,3) index_row(1))
thus "Matrix.row (A * Q) 0 $v x * (Matrix.row Q' x ∙ B) = 0" by simp
qed
have set_rw: "{0..<n} - {0} = {1..<n}"
by (simp add: atLeast0LessThan atLeast1_lessThan_eq_remove0)
have mat_rw: "(A*Q*Q')*⇩v B = A*Q*⇩v(Q' *⇩v B)"
by (rule assoc_mult_mat_vec, insert Q Q' B AQ, auto)
from eq have "A *⇩vB = (A*Q)*⇩v(Q'*⇩v B)" using mat_rw by auto
from this have "(A *⇩v B) $v 0 = (A * Q *⇩v (Q' *⇩v B)) $v 0" by auto
also have "... = Matrix.row (A*Q) 0 ∙ (Q' *⇩v B)"
by (rule index_mult_mat_vec, insert a B_def n0, auto)
also have "... = (∑i = 0..<n. ?g i)" using Q' by (auto simp add: scalar_prod_def)
also have "... = ?g 0 + (∑i ∈ {0..<n} - {0}. ?g i)"
by (metis (no_types, lifting) Q atLeast0LessThan carrier_matD(2) finite_atLeastLessThan
lessThan_iff q0 sum.remove)
also have "... = ?g 0 + (∑i = 1..<n. ?g i)" using set_rw by simp
also have "... = ?g 0" using sum0 by auto
also have "... = d * (Matrix.row Q' 0 ∙ B)" by (simp add: a d_def q0)
finally show "x ∈ ideal_generated {d}" using AB_00_x unfolding ideal_generated_singleton
using mult.commute by auto
qed
ultimately show ?thesis by auto
qed
thus "principal_ideal I" unfolding principal_ideal_def ig_S by blast
qed
qed
subsection ‹Elementary divisor ring implies Hermite ring›
context
assumes "SORT_CONSTRAINT('a::comm_ring_1)"
begin
lemma triangularizable_m0:
assumes A: "A ∈ carrier_mat m 0"
shows "∃U. U ∈ carrier_mat 0 0 ∧ invertible_mat U ∧ lower_triangular (A * U)"
using A unfolding lower_triangular_def carrier_mat_def invertible_mat_def inverts_mat_def
by auto (metis gr_implies_not0 index_one_mat(2) index_one_mat(3) right_mult_one_mat')
lemma triangularizable_0n:
assumes A: "A ∈ carrier_mat 0 n"
shows "∃U. U ∈ carrier_mat n n ∧ invertible_mat U ∧ lower_triangular (A * U)"
using A unfolding lower_triangular_def carrier_mat_def invertible_mat_def inverts_mat_def
by auto (metis index_one_mat(2) index_one_mat(3) right_mult_one_mat')
lemma diagonal_imp_triangular_1x2:
assumes A: "A ∈ carrier_mat 1 2" and d: "admits_diagonal_reduction (A::'a mat)"
shows "admits_triangular_reduction A"
proof -
obtain P Q where P: "P ∈ carrier_mat (dim_row A) (dim_row A)"
and Q: "Q ∈ carrier_mat (dim_col A) (dim_col A)"
and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
and SNF: "Smith_normal_form_mat (P * A * Q)"
using d unfolding admits_diagonal_reduction_def by blast
have "(P * A * Q) = P * (A * Q)" using P Q assoc_mult_mat by blast
also have "... = P $$ (0,0) ⋅⇩m (A * Q)" by (rule smult_mat_mat_one_element, insert P A Q, auto)
also have "... = A * (P $$ (0,0) ⋅⇩m Q)" using Q by auto
finally have eq: "(P * A * Q) = A * (P $$ (0,0) ⋅⇩m Q)" .
have inv: "invertible_mat (P $$ (0,0) ⋅⇩m Q)"
proof -
have d: "Determinant.det P = P $$ (0, 0)" by (rule determinant_one_element, insert P A, auto)
from this have P_dvd_1: "P $$ (0, 0) dvd 1"
using invertible_iff_is_unit_JNF[OF P] using inv_P by auto
have Q_dvd_1: "Determinant.det Q dvd 1" using inv_Q invertible_iff_is_unit_JNF[OF Q] by simp
have "Determinant.det (P $$ (0, 0) ⋅⇩m Q) = P $$ (0, 0) ^ dim_col Q * Determinant.det Q"
unfolding det_smult by auto
also have "... dvd 1" using P_dvd_1 Q_dvd_1 unfolding is_unit_mult_iff
by (metis dvdE dvd_mult_left one_dvd power_mult_distrib power_one)
finally have det: "(Determinant.det (P $$ (0, 0) ⋅⇩m Q) dvd 1)" .
have PQ: "P $$ (0,0) ⋅⇩m Q ∈ carrier_mat 2 2" using A P Q by auto
show ?thesis using invertible_iff_is_unit_JNF[OF PQ] det by auto
qed
moreover have "lower_triangular (A * (P $$ (0,0) ⋅⇩m Q))" unfolding lower_triangular_def using SNF eq
unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto
moreover have "(P $$ (0,0) ⋅⇩m Q) ∈ carrier_mat (dim_col A) (dim_col A)" using P Q A by auto
ultimately show ?thesis unfolding admits_triangular_reduction_def by auto
qed
lemma triangular_imp_diagonal_1x2:
assumes A: "A ∈ carrier_mat 1 2" and t: "admits_triangular_reduction (A::'a mat)"
shows "admits_diagonal_reduction A"
proof -
obtain U where U: "U ∈ carrier_mat (dim_col A) (dim_col A)"
and inv_U: "invertible_mat U" and AU: "lower_triangular (A * U)"
using t unfolding admits_triangular_reduction_def by blast
have SNF_AU: "Smith_normal_form_mat (A * U)"
using AU A unfolding Smith_normal_form_mat_def lower_triangular_def isDiagonal_mat_def by auto
have "A * U = (1⇩m 1) * A * U" using A by auto
hence SNF: "Smith_normal_form_mat ((1⇩m 1) * A * U)" using SNF_AU by auto
moreover have "invertible_mat (1⇩m 1)"
using invertible_mat_def inverts_mat_def by fastforce
ultimately show ?thesis using inv_U unfolding admits_diagonal_reduction_def
by (smt U assms(1) carrier_matD(1) one_carrier_mat)
qed
lemma triangular_eq_diagonal_1x2:
"(∀A∈carrier_mat 1 2. admits_triangular_reduction (A::'a mat))
= (∀A∈carrier_mat 1 2. admits_diagonal_reduction (A::'a mat))"
using triangular_imp_diagonal_1x2 diagonal_imp_triangular_1x2 by auto
lemma admits_triangular_mat_1x1:
assumes A: "A ∈ carrier_mat 1 1"
shows "admits_triangular_reduction (A::'a mat)"
by (rule admits_triangular_reduction_intro[of "1⇩m 1"], insert A,
auto simp add: admits_triangular_reduction_def lower_triangular_def)
lemma admits_diagonal_mat_1x1:
assumes A: "A ∈ carrier_mat 1 1"
shows "admits_diagonal_reduction (A::'a mat)"
by (rule admits_diagonal_reduction_intro[of "(1⇩m 1)" _ "(1⇩m 1)"],
insert A, auto simp add: Smith_normal_form_mat_def isDiagonal_mat_def)
lemma admits_diagonal_imp_admits_triangular_1xn:
assumes a: "∀A∈carrier_mat 1 2. admits_diagonal_reduction (A::'a mat)"
shows "∀A∈carrier_mat 1 n. admits_triangular_reduction (A::'a mat)"
proof
fix A::"'a mat" assume A: "A ∈ carrier_mat 1 n"
have "∃U. U ∈ carrier_mat (dim_col A) (dim_col A)
∧ invertible_mat U ∧ lower_triangular (A * U)"
using A
proof (induct n arbitrary: A rule: less_induct)
case (less n)
note A = less.prems(1)
show ?case
proof (cases "n=0")
case True
then show ?thesis using triangularizable_m0 triangularizable_0n less.prems by auto
next
case False note nm_not_0 = False
from this have n_not_0: "n ≠ 0" by auto
show ?thesis
proof (cases "n>2")
case False note n_less_2 = False
show ?thesis using admits_triangular_mat_1x1 a diagonal_imp_triangular_1x2
unfolding admits_triangular_reduction_def
by (metis (full_types) admits_triangular_mat_1x1 Suc_1 admits_triangular_reduction_def
less(2) less_Suc_eq less_one linorder_neqE_nat n_less_2 nm_not_0 triangular_eq_diagonal_1x2)
next
case True note n_ge_2 = True
let ?B = "mat_of_row (vec_last (Matrix.row A 0) (n - 1))"
have "∃V. V∈ carrier_mat (dim_col ?B) (dim_col ?B)
∧ invertible_mat V ∧ lower_triangular (?B * V)"
proof (rule less.hyps)
show "n-1 < n" using n_not_0 by auto
show "mat_of_row (vec_last (Matrix.row A 0) (n - 1)) ∈ carrier_mat 1 (n - 1)"
using A by simp
qed
from this obtain V where inv_V: "invertible_mat V" and BV: "lower_triangular (?B * V)"
and V': "V ∈ carrier_mat (dim_col ?B) (dim_col ?B)"
by fast
have V: "V ∈ carrier_mat (n-1) (n-1)" using V' by auto
have BV_0: "∀j ∈ {1..<n-1}. (?B * V) $$ (0,j) = 0"
by (rule, rule lower_triangular_index[OF BV], insert V, auto)
define b where "b = (?B * V) $$ (0,0)"
define a where "a = A $$ (0,0)"
define ab::"'a mat" where "ab = Matrix.mat 1 2 (λ(i,j). if i=0 ∧ j=0 then a else b)"
have ab[simp]: "ab ∈ carrier_mat 1 2" unfolding ab_def by simp
hence "admits_diagonal_reduction ab" using a by auto
hence "admits_triangular_reduction ab" using diagonal_imp_triangular_1x2[OF ab] by auto
from this obtain W where inv_W: "invertible_mat W" and ab_W: "lower_triangular (ab * W)"
and W: "W ∈ carrier_mat 2 2"
unfolding admits_triangular_reduction_def using ab by auto
have id_n2_carrier[simp]: "1⇩m (n-2) ∈ carrier_mat (n-2) (n-2)" by auto
define U where "U = (four_block_mat (1⇩m 1) (0⇩m 1 (n-1)) (0⇩m (n-1) 1) V) *
(four_block_mat W (0⇩m 2 (n-2)) (0⇩m (n-2) 2) (1⇩m (n-2)))"
let ?U1 = "four_block_mat (1⇩m 1) (0⇩m 1 (n-1)) (0⇩m (n-1) 1) V"
let ?U2 = "four_block_mat W (0⇩m 2 (n-2)) (0⇩m (n-2) 2) (1⇩m (n-2))"
have U1[simp]: "?U1 ∈carrier_mat n n" using four_block_carrier_mat[OF _ V] nm_not_0
by fastforce
have U2[simp]: "?U2 ∈carrier_mat n n" using four_block_carrier_mat[OF W id_n2_carrier]
by (metis True add_diff_inverse_nat less_imp_add_positive not_add_less1)
have U[simp]: "U ∈ carrier_mat n n" unfolding U_def using U1 U2 by auto
moreover have inv_U: "invertible_mat U"
proof -
have "invertible_mat ?U1"
by (metis U1 V det_four_block_mat_lower_left_zero_col det_one inv_V
invertible_iff_is_unit_JNF more_arith_simps(5) one_carrier_mat zero_carrier_mat)
moreover have "invertible_mat ?U2"
proof -
have "Determinant.det ?U2 = Determinant.det W"
by (rule det_four_block_mat_lower_right_id, insert less.prems W n_ge_2, auto)
also have " ... dvd 1"
using W inv_W invertible_iff_is_unit_JNF by auto
finally show ?thesis using invertible_iff_is_unit_JNF[OF U2] by auto
qed
ultimately show ?thesis
using U1 U2 U_def invertible_mult_JNF by blast
qed
moreover have "lower_triangular (A*U)"
proof -
let ?A = "Matrix.mat 1 n (λ(i,j). if j = 0 then a else if j=1 then b else 0)"
let ?T = "Matrix.mat 1 n (λ(i,j). if j = 0 then (ab*W) $$ (0,0) else 0)"
have "A*?U1 = ?A"
proof (rule eq_matI)
fix i j assume i: "i<dim_row ?A" and j: "j<dim_col ?A"
have i0: "i=0" using i by auto
let ?f = "λ i. A $$ (0, i) *
(if i = 0 then if j < 1 then 1⇩m (1) $$ (i, j) else 0⇩m (1) (n - 1) $$ (i, j - 1)
else if j < 1 then 0⇩m (n - 1) (1) $$ (i - 1, j) else V $$ (i - 1, j - 1))"
have "(A*?U1) $$ (i,j) = Matrix.row A i ∙ col ?U1 j"
by (rule index_mult_mat, insert i j A V, auto)
also have "... = (∑i = 0..<n. ?f i)"
using i j A V unfolding scalar_prod_def
by auto (unfold index_one_mat, insert One_nat_def, presburger)
also have "... = ?A $$ (i,j)"
proof (cases "j=0")
case True
have rw0: "sum ?f {1..<n} = 0" by (rule sum.neutral, insert True, auto)
have set_rw: "{0..<n} = insert 0 {1..<n}" using n_ge_2 by auto
hence "sum ?f {0..<n} = ?f 0 + sum ?f {1..<n}" by auto
also have "... = ?f 0" unfolding rw0 by simp
also have "... = a" using True unfolding a_def by simp
also have "... = ?A $$ (i,j)" using True i j by auto
finally show ?thesis .
next
case False note j_not_0 = False
have rw_simp: "Matrix.row (mat_of_row (vec_last (Matrix.row A 0) (n - 1))) 0
= (vec_last (Matrix.row A 0) (n - 1))" unfolding Matrix.row_def by auto
let ?g = "λi. A $$ (0, i) * V $$ (i - 1, j - 1)"
let ?h = "λi. A $$ (0, i+1) * V $$ (i, j - 1)"
have f0: "?f 0 = 0" using j_not_0 j by auto
have set_rw2: "(λi. i+1)`{0..<n-1} = {1..<n}"
unfolding image_def using Suc_le_D by fastforce
have set_rw: "{0..<n} = insert 0 {1..<n}" using n_ge_2 by auto
hence "sum ?f {0..<n} = ?f 0 + sum ?f {1..<n}" by auto
also have "... = sum ?f {1..<n}" using f0 by simp
also have "... = sum ?g {1..<n}" by (rule sum.cong, insert j_not_0, auto)
also have "... = sum ?g ((λi. i+1)`{0..<n-1})" using set_rw2 by simp
also have "... = sum (?g ∘ (λi. i+1)) {0..<n-1}"
by (rule sum.reindex, unfold inj_on_def, auto)
also have "... = sum ?h {0..<n-1}" by (rule sum.cong, auto)
also have "... = Matrix.row ?B 0 ∙ col V (j-1)" unfolding scalar_prod_def
proof (rule sum.cong)
fix x assume x: "x ∈ {0..<dim_vec (col V (j - 1))}"
have "Matrix.row ?B 0 $v x = ?B $$ (0,x)" by (rule index_row, insert x V, auto)
also have "... = (vec_last (Matrix.row A 0) (n - 1)) $v x"
by (rule mat_of_row_index, insert x V, auto)
also have "... = A $$ (0, x + 1)"
by (smt Suc_less_eq V add.right_neutral add_Suc_right add_diff_cancel_right'
add_diff_inverse_nat atLeastLessThan_iff carrier_matD(1) carrier_matD(2)
dim_col index_row(1) index_row(2) index_vec less.prems less_Suc0 n_not_0
plus_1_eq_Suc vec_last_def x)
finally have "Matrix.row ?B 0 $v x = A $$ (0, x + 1)" .
moreover have "col V (j - 1) $v x = V $$ (x, j - 1)" using V j x by auto
ultimately show "A $$ (0, x + 1) * V $$ (x, j - 1)
= Matrix.row ?B 0 $v x * col V (j - 1) $v x" by simp
qed (insert V j_not_0, auto)
also have "... = (?B*V) $$ (0,j-1)"
by (rule index_mult_mat[symmetric], insert V j False, auto)
also have "... = ?A $$ (i, j)"
by (cases "j=1", insert False V j i0 BV_0 b_def, auto simp add: Suc_leI)
finally show ?thesis .
qed
finally show "(A*?U1) $$ (i,j) = ?A $$ (i,j)" .
next
show "dim_row (A*?U1) = dim_row ?A" using A by auto
show "dim_col (A*?U1) = dim_col ?A" using U1 by auto
qed
also have "... * ?U2 = ?T"
proof -
let ?A1.0 = "ab"
let ?B1.0 = "Matrix.mat 1 (n-2) (λ(i,j). 0)"
let ?C1.0 = "Matrix.mat 0 2 (λ(i,j). 0)"
let ?D1.0 = "Matrix.mat 0 (n-2) (λ(i,j). 0)"
let ?B2.0 = "(0⇩m 2 (n - 2))"
let ?C2.0 = "(0⇩m (n - 2) 2)"
let ?D2.0 = "1⇩m (n - 2)"
have A_eq: "?A = four_block_mat ?A1.0 ?B1.0 ?C1.0 ?D1.0"
by (rule eq_matI, insert ab_def n_ge_2, auto)
hence "?A * ?U2 = four_block_mat ?A1.0 ?B1.0 ?C1.0 ?D1.0 * ?U2" by simp
also have "... = four_block_mat (?A1.0 * W + ?B1.0 * ?C2.0)
(?A1.0 * ?B2.0 + ?B1.0 * ?D2.0) (?C1.0 * W + ?D1.0 * ?C2.0)
(?C1.0 * ?B2.0 + ?D1.0 * ?D2.0)"
by (rule mult_four_block_mat, auto simp add: W ab_def)
also have "... = four_block_mat (?A1.0 * W) (?B1.0) (?C1.0) (?D1.0)"
by (rule cong_four_block_mat, insert W ab_def, auto)
also have "... = ?T"
by (rule eq_matI, insert W n_ge_2 ab_def ab_W, auto simp add: lower_triangular_def)
finally show ?thesis .
qed
finally have "A * U = ?T"
using assoc_mult_mat[OF _ U1 U2] less.prems unfolding U_def by auto
moreover have "lower_triangular ?T" unfolding lower_triangular_def by simp
ultimately show ?thesis by simp
qed
ultimately show ?thesis using A U by blast
qed
qed
qed
from this show "admits_triangular_reduction A" unfolding admits_triangular_reduction_def by simp
qed
lemma admits_diagonal_imp_admits_triangular:
assumes a: "∀A∈carrier_mat 1 2. admits_diagonal_reduction (A::'a mat)"
shows "∀A. admits_triangular_reduction (A::'a mat)"
proof
fix A::"'a mat"
obtain m n where A: "A ∈ carrier_mat m n" by auto
have "∃U. U ∈ carrier_mat n n ∧ invertible_mat U ∧ lower_triangular (A * U)"
using A
proof (induct n arbitrary: m A rule: less_induct)
case (less n)
note A = less.prems(1)
show ?case
proof (cases "n=0 ∨ m=0")
case True
then show ?thesis using triangularizable_m0 triangularizable_0n less.prems by auto
next
case False note nm_not_0 = False
from this have m_not_0: "m ≠ 0" and n_not_0: "n ≠ 0" by auto
show ?thesis
proof (cases "m = 1")
case True note m1 = True
show ?thesis using admits_diagonal_imp_admits_triangular_1xn A m1 a
unfolding admits_triangular_reduction_def by blast
next
case False note m_not_1 = False
show ?thesis
proof (cases "n=1")
case True
thus ?thesis using invertible_mat_zero lower_triangular_def
by (metis carrier_matD(2) det_one gr_implies_not0 invertible_iff_is_unit_JNF less(2)
less_one one_carrier_mat right_mult_one_mat')
next
case False note n_not_1 = False
let ?first_row = "mat_of_row (Matrix.row A 0)"
have first_row: "?first_row ∈ carrier_mat 1 n" using less.prems by auto
have m1: "m>1" using m_not_1 m_not_0 by linarith
have n1: "n>1" using n_not_1 n_not_0 by linarith
obtain V where lt_first_row_V: "lower_triangular (?first_row * V)"
and inv_V: "invertible_mat V" and V: "V ∈ carrier_mat n n"
using admits_diagonal_imp_admits_triangular_1xn a first_row
unfolding admits_triangular_reduction_def by blast
have AV: "A*V ∈ carrier_mat m n" using V less by auto
have dim_row_AV: "dim_row (A * V) = 1 + (m-1)" using m1 AV by auto
have dim_col_AV: "dim_col (A * V) = 1 + (n-1)" using n1 AV by fastforce
have reduced_first_row: "Matrix.row (?first_row * V) 0 = Matrix.row (A * V) 0"
by (rule mult_eq_first_row, insert first_row m1 less.prems, auto)
obtain a zero B C where split: "split_block (A*V) 1 1 = (a, zero, B, C)"
using prod_cases4 by blast
have a: "a ∈ carrier_mat 1 1" and zero: "zero ∈ carrier_mat 1 (n-1)" and
B: "B ∈ carrier_mat (m-1) 1" and C: "C ∈ carrier_mat (m-1) (n-1)"
by (rule split_block[OF split dim_row_AV dim_col_AV])+
have AV_block: "A*V = four_block_mat a zero B C"
by (rule split_block[OF split dim_row_AV dim_col_AV])
have "∃W. W∈ carrier_mat (n-1) (n-1) ∧ invertible_mat W ∧ lower_triangular (C*W)"
by (rule less.hyps, insert n1 C, auto)
from this obtain W where inv_W: "invertible_mat W" and lt_CW: "lower_triangular (C*W)"
and W: "W ∈ carrier_mat (n-1) (n-1)" by blast
let ?W2 = "four_block_mat (1⇩m 1) (0⇩m 1 (n-1)) (0⇩m (n-1) 1) W"
have W2: "?W2 ∈ carrier_mat n n" using V W dim_col_AV by auto
have "Determinant.det ?W2 = Determinant.det (1⇩m 1) * Determinant.det W"
by (rule det_four_block_mat_lower_left_zero_col[OF _ _ _ W], auto)
hence det_W2: "Determinant.det ?W2 = Determinant.det W" by auto
hence inv_W2: "invertible_mat ?W2"
by (metis W four_block_carrier_mat inv_W invertible_iff_is_unit_JNF one_carrier_mat)
have inv_V_W2: "invertible_mat (V * ?W2)" using inv_W2 inv_V V W2 invertible_mult_JNF by blast
have "lower_triangular (A*V*?W2)"
proof -
let ?T = "(four_block_mat a (0⇩m 1 (n-1)) B (C * W))"
have zero_eq: "zero = 0⇩m 1 (n-1)"
proof (rule eq_matI)
show 1: "dim_row zero = dim_row (0⇩m 1 (n - 1))" and 2: "dim_col zero = dim_col (0⇩m 1 (n - 1))"
using zero by auto
fix i j assume i: "i < dim_row (0⇩m 1 (n - 1))" and j: "j < dim_col (0⇩m 1 (n - 1))"
have i0: "i=0" using i by auto
have "0 = Matrix.row (?first_row * V) 0 $v (j+1)"
using lt_first_row_V j unfolding lower_triangular_def
by (metis Suc_eq_plus1 carrier_matD(2) index_mult_mat(2,3) index_row(1) less_diff_conv
mat_of_row_dim(1) zero zero_less_Suc zero_less_one_class.zero_less_one V 2)
also have "... = Matrix.row (A*V) 0 $v (j+1)" by (simp add: reduced_first_row)
also have "... = (A*V) $$ (i, j+1)" using V dim_row_AV i0 j by auto
also have "... = four_block_mat a zero B C $$ (i, j+1)" by (simp add: AV_block)
also have "... = (if i < dim_row a then if (j+1) < dim_col a
then a $$ (i, (j+1)) else zero $$ (i, (j+1) - dim_col a) else if (j+1) < dim_col a
then B $$ (i - dim_row a, (j+1)) else C $$ (i - dim_row a, (j+1) - dim_col a))"
by (rule index_mat_four_block, insert a zero i j C, auto)
also have "... = zero $$ (i, (j+1) - dim_col a)" using a zero i j C by auto
also have "... = zero $$ (i, j)" using a i by auto
finally show "zero $$ (i, j) = 0⇩m 1 (n - 1) $$ (i, j)" using i j by auto
qed
have rw1: "a * (1⇩m 1) + zero * (0⇩m (n-1) 1) = a" using a zero by auto
have rw2: "a * (0⇩m 1 (n-1)) + zero * W = 0⇩m 1 (n-1)" using a zero zero_eq W by auto
have rw3: "B * (1⇩m 1) + C * (0⇩m (n-1) 1) = B" using B C by auto
have rw4: "B * (0⇩m 1 (n-1)) + C * W = C * W" using B C W by auto
have "A*V = four_block_mat a zero B C" by (rule AV_block)
also have "... * ?W2 = four_block_mat (a * (1⇩m 1) + zero * (0⇩m (n-1) 1))
(a * (0⇩m 1 (n-1)) + zero * W) (B * (1⇩m 1) + C * (0⇩m (n-1) 1))
(B * (0⇩m 1 (n-1)) + C * W)" by (rule mult_four_block_mat[OF a zero B C], insert W, auto)
also have "... = ?T" using rw1 rw2 rw3 rw4 by simp
finally have AVW2: "A*V * ?W2 = ..." .
moreover have "lower_triangular ?T"
using lt_CW unfolding lower_triangular_def using a zero B C W
by (auto, metis (full_types) Suc_less_eq Suc_pred basic_trans_rules(19))
ultimately show ?thesis by simp
qed
then show ?thesis using inv_V_W2 V W2 less.prems
by (smt assoc_mult_mat mult_carrier_mat)
qed
qed
qed
qed
thus "admits_triangular_reduction A" using A unfolding admits_triangular_reduction_def by simp
qed
corollary admits_diagonal_imp_admits_triangular':
assumes a: "∀A. admits_diagonal_reduction (A::'a mat)"
shows "∀A. admits_triangular_reduction (A::'a mat)"
using admits_diagonal_imp_admits_triangular assms by blast
lemma admits_triangular_reduction_1x2:
assumes "∀A::'a mat. A ∈ carrier_mat 1 2 ⟶ admits_triangular_reduction A"
shows "∀C::'a mat. admits_triangular_reduction C"
using admits_diagonal_imp_admits_triangular assms triangular_eq_diagonal_1x2 by auto
lemma Hermite_ring_OFCLASS:
assumes "∀A ∈ carrier_mat 1 2. admits_triangular_reduction (A::'a mat)"
shows "OFCLASS('a, Hermite_ring_class)"
proof
show "∀A::'a mat. admits_triangular_reduction A"
by (rule admits_diagonal_imp_admits_triangular[OF assms[unfolded triangular_eq_diagonal_1x2]])
qed
lemma Hermite_ring_OFCLASS':
assumes "∀A ∈ carrier_mat 1 2.admits_diagonal_reduction (A::'a mat)"
shows "OFCLASS('a, Hermite_ring_class)"
proof
show "∀A::'a mat. admits_triangular_reduction A"
by (rule admits_diagonal_imp_admits_triangular[OF assms])
qed
lemma theorem3_part1:
assumes T: "(∀a b::'a. ∃ a1 b1 d. a = a1*d ∧ b = b1*d
∧ ideal_generated {a1,b1} = ideal_generated {1})"
shows "∀A::'a mat. admits_triangular_reduction A"
proof (rule admits_triangular_reduction_1x2, rule allI, rule impI)
fix A::"'a mat"
assume A: "A ∈ carrier_mat 1 2"
let ?a = "A $$ (0,0)"
let ?b = "A $$ (0,1)"
obtain a1 b1 d where a: "?a = a1*d" and b: "?b = b1*d"
and i: "ideal_generated {a1,b1} = ideal_generated {1}"
using T by blast
obtain s t where sa1tb1:"s*a1+t*b1=1" using ideal_generated_pair_exists_pq1[OF i[simplified]] by blast
let ?Q = "Matrix.mat 2 2 (λ(i,j). if i = 0 ∧ j = 0 then s else
if i = 0 ∧ j = 1 then -b1 else
if i = 1 ∧ j = 0 then t else a1)"
have Q: "?Q ∈ carrier_mat 2 2" by auto
have det_Q: "Determinant.det ?Q = 1" unfolding det_2[OF Q]
using sa1tb1 by (simp add: mult.commute)
hence inv_Q: "invertible_mat ?Q" using invertible_iff_is_unit_JNF[OF Q] by auto
have lower_AQ: "lower_triangular (A*?Q)"
proof -
have "Matrix.row A 0 $v Suc 0 * a1 = Matrix.row A 0 $v 0 * b1" if j2: "j<2" and j0: "0<j" for j
by (metis A One_nat_def a b carrier_matD(1) carrier_matD(2) index_row(1) lessI
more_arith_simps(11) mult.commute numeral_2_eq_2 pos2)
thus ?thesis unfolding lower_triangular_def using A
by (auto simp add: scalar_prod_def sum_two_rw)
qed
show "admits_triangular_reduction A"
unfolding admits_triangular_reduction_def using lower_AQ inv_Q Q A by force
qed
lemma theorem3_part2:
assumes 1: "∀A::'a mat. admits_triangular_reduction A"
shows "∀a b::'a. ∃ a1 b1 d. a = a1*d ∧ b = b1*d ∧ ideal_generated {a1,b1} = ideal_generated {1}"
proof (rule allI)+
fix a b::'a
let ?A = "Matrix.mat 1 2 (λ(i,j). if i = 0 ∧ j = 0 then a else b)"
obtain Q where AQ: "lower_triangular (?A*Q)" and inv_Q: "invertible_mat Q"
and Q: "Q ∈ carrier_mat 2 2"
using 1 unfolding admits_triangular_reduction_def by fastforce
hence [simp]: "dim_col Q = 2" and [simp]: "dim_row Q = 2" by auto
let ?s = "Q $$ (0,0)"
let ?t = "Q $$ (1,0)"
let ?a1 = "Q $$ (1,1)"
let ?b1 = "-(Q $$ (0,1))"
let ?d = "(?A*Q) $$ (0,0)"
have ab1_ba1: "a*?b1 = b*?a1"
proof -
have "(?A*Q) $$ (0,1) = (∑i = 0..<2. (if i = 0 then a else b) * Q $$ (i, Suc 0))"
unfolding times_mat_def col_def scalar_prod_def by auto
also have "... = (∑i ∈ {0,1}. (if i = 0 then a else b) * Q $$ (i, Suc 0))"
by (rule sum.cong, auto)
also have "... = - a*?b1 + b*?a1" by auto
finally have "(?A*Q) $$ (0,1) = - a*?b1 + b*?a1" by simp
moreover have "(?A*Q) $$ (0,1) = 0" using AQ unfolding lower_triangular_def by auto
ultimately show ?thesis
by (metis add_left_cancel more_arith_simps(3) more_arith_simps(7))
qed
have sa_tb_d: "?s*a+?t*b = ?d"
proof -
have "?d = (∑i = 0..<2. (if i = 0 then a else b) * Q $$ (i, 0))"
unfolding times_mat_def col_def scalar_prod_def by auto
also have "... = (∑i ∈ {0,1}. (if i = 0 then a else b) * Q $$ (i, 0))" by (rule sum.cong, auto)
also have "... = ?s*a+?t*b" by auto
finally show ?thesis by simp
qed
have det_Q_dvd_1: "(Determinant.det Q dvd 1)"
using invertible_iff_is_unit_JNF[OF Q] inv_Q by auto
moreover have det_Q_eq: "Determinant.det Q = ?s*?a1 + ?t*?b1" unfolding det_2[OF Q] by simp
ultimately have "?s*?a1 + ?t*?b1 dvd 1" by auto
from this obtain u where u_eq: "?s*?a1 + ?t*?b1 = u" and u: "u dvd 1" by auto
hence eq1: "?s*?a1*a + ?t*?b1*a = u*a"
by (metis ring_class.ring_distribs(2))
hence "?s*?a1*a + ?t*?a1*b = u*a"
by (metis (no_types, lifting) ab1_ba1 mult.assoc mult.commute)
hence a1d_ua:"?a1*?d=u*a"
by (smt Groups.mult_ac(2) distrib_left more_arith_simps(11) sa_tb_d)
hence b1d_ub: "?b1*?d=u*b"
by (smt Groups.mult_ac(2) Groups.mult_ac(3) ab1_ba1 distrib_right sa_tb_d u_eq)
obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
by (metis mult.commute)
hence inv_u_dvd_1: "inv_u dvd 1" unfolding dvd_def by auto
have cond1: "(inv_u*?b1)*?d = b" using b1d_ub inv_u
by (metis (no_types, lifting) Groups.mult_ac(3) more_arith_simps(11) more_arith_simps(6))
have cond2: "(inv_u*?a1)*?d = a" using a1d_ua inv_u
by (metis (no_types, lifting) Groups.mult_ac(3) more_arith_simps(11) more_arith_simps(6))
have "ideal_generated {inv_u*?a1, inv_u*?b1} = ideal_generated {?a1,?b1}"
by (rule ideal_generated_mult_unit2[OF inv_u_dvd_1])
also have "... = UNIV" using ideal_generated_pair_UNIV[OF u_eq u] by simp
finally have cond3: "ideal_generated {inv_u*?a1, inv_u*?b1} = ideal_generated {1}" by auto
show "∃a1 b1 d. a = a1 * d ∧ b = b1 * d ∧ ideal_generated {a1, b1} = ideal_generated {1}"
by (rule exI[of _ "inv_u*?a1"], rule exI[of _ "inv_u*?b1"], rule exI[of _ ?d],
insert cond1 cond2 cond3, auto)
qed
theorem theorem3:
shows "(∀A::'a mat. admits_triangular_reduction A)
= (∀a b::'a. ∃ a1 b1 d. a = a1*d ∧ b = b1*d ∧ ideal_generated {a1,b1} = ideal_generated {1})"
using theorem3_part1 theorem3_part2 by auto
end
context comm_ring_1
begin
lemma lemma4_prev:
assumes a: "a = a1*d" and b: "b = b1*d"
and i: "ideal_generated {a1,b1} = ideal_generated {1}"
shows "ideal_generated {a,b} = ideal_generated {d}"
proof -
have 1: "∃k. p * (a1 * d) + q * (b1 * d) = k * d" for p q
by (metis (full_types) local.distrib_right local.mult.semigroup_axioms semigroup.assoc)
have "ideal_generated {a,b} ⊆ ideal_generated {d}"
proof -
have "ideal_generated {a,b} = {p*a+q*b | p q. True}" using ideal_generated_pair by auto
also have "... = {p*(a1*d)+q*(b1*d) | p q. True}" using a b by auto
also have "... ⊆ {k*d|k. True}" using 1 by auto
finally show ?thesis
by (simp add: a b local.dvd_ideal_generated_singleton' local.ideal_generated_subset2)
qed
moreover have "ideal_generated{d} ⊆ ideal_generated {a,b}"
proof (rule ideal_generated_singleton_subset)
obtain p q where "p*a1+q*b1 = 1" using ideal_generated_pair_exists_UNIV i by auto
hence "d = p * (a1 * d) + q * (b1 * d)"
by (metis local.mult_ac(3) local.ring_distribs(1) local.semiring_normalization_rules(12))
also have "... ∈ {p*(a1*d)+q*(b1*d) | p q. True}" by auto
also have "... = ideal_generated {a,b}" unfolding ideal_generated_pair a b by auto
finally show "d ∈ ideal_generated {a,b}" by simp
qed (simp)
ultimately show ?thesis by simp
qed
lemma lemma4:
assumes a: "a = a1*d" and b: "b = b1*d"
and i: "ideal_generated {a1,b1} = ideal_generated {1}"
and i2: "ideal_generated {a,b} = ideal_generated {d'}"
shows "∃a1' b1'. a = a1' * d' ∧ b = b1' * d'
∧ ideal_generated {a1',b1'} = ideal_generated {1}"
proof -
have i3: "ideal_generated {a,b} = ideal_generated {d}" using lemma4_prev assms by auto
have d_dvd_d': "d dvd d'"
by (metis a b i2 dvd_ideal_generated_singleton dvd_ideal_generated_singleton'
dvd_triv_right ideal_generated_subset2)
have d'_dvd_d: "d' dvd d"
using i3 i2 local.dvd_ideal_generated_singleton by auto
obtain k and l where d: "d = k*d'" and d': "d' = l*d"
using d_dvd_d' d'_dvd_d mult_ac unfolding dvd_def by auto
obtain s t where sa1_tb1: "s*a1 + t*b1 = 1"
using i ideal_generated_pair_exists_UNIV[of a1 b1] by auto
let ?a1' = "k * l * t - t + a1 * k"
let ?b1' = "s - k * l * s + b1 * k"
have 1: "?a1'*d'=a"
by (metis a d d' add_ac(2) add_diff_cancel add_diff_eq mult_ac(2) ring_distribs(1,4)
semiring_normalization_rules(18))
have 2: "?b1'*d' = b"
by (metis (no_types, hide_lams) b d d' add_ac(2) add_diff_cancel add_diff_eq mult_ac(2) mult_ac(3)
ring_distribs(2,4) semiring_normalization_rules(18))
have "(s*l-b1)*?a1' + (t*l+a1)*?b1' = 1"
proof -
have aux_rw1: "s * l * k * l * t = t * l * k * l * s" and aux_rw2: "s * l * t=t * l * s"
and aux_rw3: "b1 * a1 * k=a1 * b1 * k" and aux_rw4: "t * l * b1 * k=b1 * k * l * t"
and aux_rw5: "s * l * a1 * k=a1 * k * l * s"
using mult.commute mult.assoc by auto
note aux_rw = aux_rw1 aux_rw2 aux_rw3 aux_rw4 aux_rw5
have "(s*l-b1)*?a1' + (t*l+a1)*?b1' = s*l*?a1' - b1*?a1' + t*l*?b1'+a1*?b1'"
using local.add_ac(1) local.left_diff_distrib' local.ring_distribs(2) by auto
also have "... = s * l * k * l*t - s * l * t + s * l * a1 * k-b1 * k * l * t + b1 * t-b1 * a1 * k
+ t * l * s-t * l * k * l * s + t * l * b1 * k + a1 * s - a1 * k * l * s + a1 * b1 * k"
by (smt abel_semigroup.commute add.abel_semigroup_axioms diff_add_eq diff_diff_eq2
mult.semigroup_axioms ring_distribs(4) semiring_normalization_rules(34) semigroup.assoc)
also have "... = a1 * s + b1 * t" unfolding aux_rw
by (smt add_ac(2) add_ac(3) add_minus_cancel ring_distribs(4) ring_normalization_rules(2))
also have "... = 1" using sa1_tb1 mult.commute by auto
finally show ?thesis by simp
qed
hence "ideal_generated {?a1',?b1'} = ideal_generated {1}"
using ideal_generated_pair_exists_UNIV[of ?a1' ?b1'] by auto
thus ?thesis using 1 2 by auto
qed
lemma corollary5:
assumes T: "∀a b. ∃a1 b1 d. a = a1 * d ∧ b = b1 * d
∧ ideal_generated {a1, b1} = ideal_generated {1::'a}"
and i2: "ideal_generated {a,b,c} = ideal_generated {d}"
shows "∃ a1 b1 c1. a = a1 * d ∧ b = b1 * d ∧ c = c1 * d
∧ ideal_generated {a1,b1,c1} = ideal_generated {1}"
proof -
have da: "d dvd a" using ideal_generated_singleton_dvd[OF i2] by auto
have db: "d dvd b" using ideal_generated_singleton_dvd[OF i2] by auto
have dc: "d dvd c" using ideal_generated_singleton_dvd[OF i2] by auto
from this obtain c1' where c: "c = c1' * d" using dvd_def mult_ac(2) by auto
obtain a1 b1 d' where a: "a = a1 * d'" and b: "b = b1 * d' "
and i: "ideal_generated {a1, b1} = ideal_generated {1::'a}" using T by blast
have i_ab_d': "ideal_generated {a, b} = ideal_generated {d'}"
by (simp add: a b i lemma4_prev)
have i2: "ideal_generated {d', c} = ideal_generated {d}"
by (rule ideal_generated_triple_pair_rewrite[OF i2 i_ab_d'])
obtain u v dp where d'1: "d' = u * dp" and d'2: "c = v * dp"
and xy: "ideal_generated{u,v}=ideal_generated{1}" using T by blast
have "∃a1' b1'. d' = a1' * d ∧ c = b1' * d ∧ ideal_generated {a1', b1'} = ideal_generated {1}"
by (rule lemma4[OF d'1 d'2 xy i2])
from this obtain a1' c1 where d'_a1: "d' = a1' * d" and c: "c = c1 * d"
and i3: "ideal_generated {a1', c1} = ideal_generated {1}" by blast
have r1: "a = a1 * a1' * d" by (simp add: d'_a1 a local.semiring_normalization_rules(18))
have r2: "b = b1 * a1' * d" by (simp add: d'_a1 b local.semiring_normalization_rules(18))
have i4: "ideal_generated {a1 * a1',b1 * a1', c1} = ideal_generated {1}"
proof -
obtain p q where 1: "p * a1' + q * c1 = 1"
using i3 unfolding ideal_generated_pair_exists_UNIV by auto
obtain x y where 2: "x*a1 + y*b1 = p" using ideal_generated_UNIV_obtain_pair[OF i] by blast
have "1 = (x*a1 + y*b1) * a1' + q * c1" using 1 2 by auto
also have "... = x*a1*a1' + y*b1*a1' + q * c1" by (simp add: local.ring_distribs(2))
finally have "1 = x*a1*a1' + y*b1*a1' + q * c1" .
hence "1 ∈ ideal_generated {a1 * a1', b1 * a1', c1}"
using ideal_explicit2[of "{a1 * a1', b1 * a1', c1}"] sum_three_elements'
by (simp add: mult_assoc)
hence "ideal_generated {1} ⊆ ideal_generated {a1 * a1',b1 * a1', c1}"
by (rule ideal_generated_singleton_subset, auto)
thus ?thesis by auto
qed
show ?thesis using r1 r2 i4 c by auto
qed
end
context
assumes "SORT_CONSTRAINT('a::comm_ring_1)"
begin
lemma OFCLASS_elementary_divisor_ring_imp_class:
assumes "OFCLASS('a::comm_ring_1, elementary_divisor_ring_class)"
shows " class.elementary_divisor_ring TYPE('a)"
by (rule conjunctionD2[OF assms[unfolded elementary_divisor_ring_class_def]])
corollary Elementary_divisor_ring_imp_Hermite_ring:
assumes "OFCLASS('a::comm_ring_1, elementary_divisor_ring_class) "
shows "OFCLASS('a::comm_ring_1, Hermite_ring_class)"
proof
have "∀A::'a mat. admits_diagonal_reduction A"
using OFCLASS_elementary_divisor_ring_imp_class[OF assms]
unfolding class.elementary_divisor_ring_def by auto
thus "∀A::'a mat. admits_triangular_reduction A"
using admits_diagonal_imp_admits_triangular by auto
qed
corollary Elementary_divisor_ring_imp_Bezout_ring:
assumes "OFCLASS('a::comm_ring_1, elementary_divisor_ring_class) "
shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
by (rule Hermite_ring_imp_Bezout_ring, rule Elementary_divisor_ring_imp_Hermite_ring[OF assms])
subsection ‹Characterization of Elementary divisor rings›
lemma necessity_D':
assumes edr: "(∀(A::'a mat). admits_diagonal_reduction A)"
shows "∀a b c::'a. ideal_generated {a,b,c} = ideal_generated{1}
⟶ (∃p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})"
proof ((rule allI)+, rule impI)
fix a b c::'a
assume i: "ideal_generated {a,b,c} = ideal_generated{1}"
define A where "A = Matrix.mat 2 2 (λ(i,j). if i = 0 ∧ j = 0 then a else
if i = 0 ∧ j = 1 then b else
if i = 1 ∧ j = 0 then 0 else c)"
have A: "A ∈ carrier_mat 2 2" unfolding A_def by auto
obtain P Q where P: "P ∈ carrier_mat (dim_row A) (dim_row A)"
and Q: "Q ∈ carrier_mat (dim_col A) (dim_col A)"
and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
and SNF_PAQ: "Smith_normal_form_mat (P * A * Q)"
using edr unfolding admits_diagonal_reduction_def by blast
have [simp]: "dim_row P = 2" and [simp]: "dim_col P = 2 " and [simp]: "dim_row Q = 2"
and [simp]: "dim_col Q = 2" and [simp]: "dim_col A = 2" and [simp]: "dim_row A = 2"
using A P Q by auto
define u where "u = (P*A*Q) $$ (0,0)"
define p where "p = P $$ (0,0)"
define q where "q = P $$ (0,1)"
define x where "x = Q $$ (0,0)"
define y where "y = Q $$ (1,0)"
have eq: "p*a*x + p*b*y + q*c*y = u"
proof -
have rw1: "(∑ia = 0..<2. P $$ (0, ia) * A $$ (ia, x)) * Q $$ (x, 0)
= (∑ia∈{0, 1}. P $$ (0, ia) * A $$ (ia, x)) * Q $$ (x, 0)"
for x by (unfold sum_distrib_right, rule sum.cong, auto)
have "u = (∑i = 0..<2. (∑ia = 0..<2. P $$ (0, ia) * A $$ (ia, i)) * Q $$ (i, 0))"
unfolding u_def p_def q_def x_def y_def
unfolding times_mat_def scalar_prod_def by auto
also have "... = (∑i ∈{0,1}. (∑ia ∈ {0,1}. P $$ (0, ia) * A $$ (ia, i)) * Q $$ (i, 0))"
by (rule sum.cong[OF _ rw1], auto)
also have "... = p*a*x + p*b*y+q*c*y"
unfolding u_def p_def q_def x_def y_def A_def
using ring_class.ring_distribs(2) by auto
finally show ?thesis ..
qed
have u_dvd_1: "u dvd 1"
proof (rule ideal_generated_dvd2[OF i])
define D where "D = (P*A*Q)"
obtain P' where P'[simp]: "P' ∈ carrier_mat 2 2" and inv_P: "inverts_mat P' P"
using inv_P obtain_inverse_matrix[OF P inv_P]
by (metis ‹dim_row A = 2›)
obtain Q' where [simp]: "Q' ∈ carrier_mat 2 2" and inv_Q: "inverts_mat Q Q'"
using inv_Q obtain_inverse_matrix[OF Q inv_Q]
by (metis ‹dim_col A = 2›)
have D[simp]: "D ∈ carrier_mat 2 2" unfolding D_def by auto
have e: "P' * D * Q' = A" unfolding D_def by (rule inv_P'PAQQ'[OF _ _ inv_P inv_Q], auto)
have [simp]: "(P' * D) ∈ carrier_mat 2 2" using D P' mult_carrier_mat by blast
have D_01: "D $$ (0, 1) = 0"
using D_def SNF_PAQ unfolding Smith_normal_form_mat_def isDiagonal_mat_def by force
have D_10: "D $$ (1, 0) = 0"
using D_def SNF_PAQ unfolding Smith_normal_form_mat_def isDiagonal_mat_def by force
have "D $$ (0,0) dvd D $$ (1, 1)"
using D_def SNF_PAQ unfolding Smith_normal_form_mat_def by auto
from this obtain k where D11: "D $$ (1, 1) = D $$ (0,0) * k" unfolding dvd_def by blast
have P'D_00: "(P' * D) $$ (0, 0) = P' $$ (0, 0) * D $$ (0, 0)"
using mat_mult2_00[of P' D] D_10 by auto
have P'D_01: "(P' * D) $$ (0, 1) = P' $$ (0, 1) * D $$ (1, 1)"
using mat_mult2_01[of P' D] D_01 by auto
have P'D_10: "(P' * D) $$ (1, 0) = P' $$ (1, 0) * D $$ (0, 0)"
using mat_mult2_10[of P' D] D_10 by auto
have P'D_11: "(P' * D) $$ (1, 1) = P' $$ (1, 1) * D $$ (1, 1)"
using mat_mult2_11[of P' D] D_01 by auto
have "a = (P' * D * Q') $$ (0,0)" using e A_def by auto
also have "... = (P' * D) $$ (0, 0) * Q' $$ (0, 0) + (P' * D) $$ (0, 1) * Q' $$ (1, 0)"
by (rule mat_mult2_00, auto)
also have "... = P' $$ (0, 0) * D $$ (0, 0) * Q' $$ (0, 0)
+ P' $$ (0, 1) * (D $$ (0, 0) * k) * Q' $$ (1, 0)" unfolding P'D_00 P'D_01 D11 ..
also have "... = D $$ (0, 0) * (P' $$ (0, 0) * Q' $$ (0, 0)
+ P' $$ (0, 1) * k * Q' $$ (1, 0))" by (simp add: distrib_left)
finally have u_dvd_a: "u dvd a" unfolding u_def D_def dvd_def by auto
have "b = (P' * D * Q') $$ (0,1)" using e A_def by auto
also have "... = (P' * D) $$ (0, 0) * Q' $$ (0, 1) + (P' * D) $$ (0, 1) * Q' $$ (1, 1)"
by (rule mat_mult2_01, auto)
also have "... = P' $$ (0, 0) * D $$ (0, 0) * Q' $$ (0, 1) +
P' $$ (0, 1) * (D $$ (0, 0) * k) * Q' $$ (1, 1)"
unfolding P'D_00 P'D_01 D11 ..
also have "... = D $$ (0, 0) * (P' $$ (0, 0) * Q' $$ (0, 1) +
P' $$ (0, 1) * k * Q' $$ (1, 1))" by (simp add: distrib_left)
finally have u_dvd_b: "u dvd b" unfolding u_def D_def dvd_def by auto
have "c = (P' * D * Q') $$ (1,1)" using e A_def by auto
also have "... = (P' * D) $$ (1, 0) * Q' $$ (0, 1) + (P' * D) $$ (1, 1) * Q' $$ (1, 1)"
by (rule mat_mult2_11, auto)
also have "... = P' $$ (1, 0) * D $$ (0, 0) * Q' $$ (0, 1)
+ P' $$ (1, 1) * (D $$ (0, 0) * k) * Q' $$ (1, 1)" unfolding P'D_11 P'D_10 D11 ..
also have "... = D $$ (0, 0) * (P' $$ (1, 0) * Q' $$ (0, 1)
+ P' $$ (1, 1) * k * Q' $$ (1, 1))" by (simp add: distrib_left)
finally have u_dvd_c: "u dvd c" unfolding u_def D_def dvd_def by auto
show "∀x∈{a,b,c}. u dvd x" using u_dvd_a u_dvd_b u_dvd_c by auto
qed (simp)
have "ideal_generated {p*a,p*b+q*c} = ideal_generated {1}"
by (metis (no_types, lifting) eq add.assoc ideal_generated_1 ideal_generated_pair_UNIV
mult.commute semiring_normalization_rules(34) u_dvd_1)
from this show "∃p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1}"
by auto
qed
lemma necessity:
assumes "(∀(A::'a mat). admits_diagonal_reduction A)"
shows "(∀(A::'a mat). admits_triangular_reduction A)"
and "∀a b c::'a. ideal_generated{a,b,c} = ideal_generated{1}
⟶ (∃p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})"
using necessity_D' admits_diagonal_imp_admits_triangular assms
by blast+
text ‹In the article, the authors change the notation and assume $(a,b,c) = (1)$. However,
we have to provide here the complete prove. To to this, I obtained a $D$ matrix such that
$A' = A*D$ and $D$ is a diagonal matrix with $d$ in the diagonal. Proving that $D$ is
left and right commutative, I can follow the reasoning in the article›
lemma sufficiency:
assumes hermite_ring: "(∀(A::'a mat). admits_triangular_reduction A)"
and D': "∀a b c::'a. ideal_generated{a,b,c} = ideal_generated{1}
⟶ (∃p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})"
shows "(∀(A::'a mat). admits_diagonal_reduction A)"
proof -
have admits_1x2: "∀(A::'a mat) ∈ carrier_mat 1 2. admits_diagonal_reduction A"
using hermite_ring triangular_eq_diagonal_1x2 by blast
have admits_2x2: "∀(A::'a mat) ∈ carrier_mat 2 2. admits_diagonal_reduction A"
proof
fix B::"'a mat" assume B: "B ∈ carrier_mat 2 2"
obtain U where BU: "lower_triangular (B*U)" and inv_U: "invertible_mat U"
and U: "U ∈ carrier_mat 2 2"
using hermite_ring unfolding admits_triangular_reduction_def using B by fastforce
define A where "A = B*U"
define a where "a = A $$ (0,0)"
define b where "b = A $$ (1,0)"
define c where "c = A $$ (1,1)"
have A: "A ∈ carrier_mat 2 2" using U B A_def by auto
have A_01: "A$$(0,1) = 0" using BU U B unfolding lower_triangular_def A_def by auto
obtain d::'a where i: "ideal_generated {a,b,c} = ideal_generated {d}"
proof -
have "OFCLASS('a, bezout_ring_class)" by (rule Hermite_ring_imp_Bezout_ring,
insert OFCLASS_Hermite_ring_def[where ?'a='a] hermite_ring, auto)
hence "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus"
using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a = 'a] by auto
hence "(∀I::'a::comm_ring_1 set. finitely_generated_ideal I ⟶ principal_ideal I)"
using bezout_ring_iff_fin_gen_principal_ideal2 by auto
moreover have "finitely_generated_ideal (ideal_generated {a,b,c})"
unfolding finitely_generated_ideal_def
using ideal_ideal_generated by force
ultimately have "principal_ideal (ideal_generated {a,b,c})" by auto
thus ?thesis using that unfolding principal_ideal_def by auto
qed
have d_dvd_a: "d dvd a" and d_dvd_b: "d dvd b" and d_dvd_c: "d dvd c"
using i ideal_generated_singleton_dvd by blast+
obtain a1 b1 c1 where a1: "a = a1 * d" and b1: "b = b1 * d" and c1: "c = c1 * d"
and i2: "ideal_generated {a1,b1,c1} = ideal_generated {1}"
proof -
have T: "∀a b. ∃a1 b1 d. a = a1 * d ∧ b = b1 * d
∧ ideal_generated {a1, b1} = ideal_generated {1::'a}"
by (rule theorem3_part2[OF hermite_ring])
from this obtain a1' b1' d' where 1: "a = a1' * d'" and 2: "b = b1' * d'"
and 3: "ideal_generated {a1', b1'} = ideal_generated {1::'a}" by blast
have "∃a1 b1 c1. a = a1 * d ∧ b = b1 * d ∧ c = c1 * d
∧ ideal_generated {a1, b1, c1} = ideal_generated {1}"
by (rule corollary5[OF T i])
from this show ?thesis using that by auto
qed
define D where "D = d ⋅⇩m (1⇩m 2)"
define A' where "A' = Matrix.mat 2 2 (λ(i,j). if i = 0 ∧ j = 0 then a1 else
if i = 1 ∧ j = 0 then b1 else
if i = 0 ∧ j = 1 then 0 else c1)"
have D: "D ∈ carrier_mat 2 2" and A': "A'∈ carrier_mat 2 2" unfolding A'_def D_def by auto
have A_A'D: "A = A' * D"
by (rule eq_matI, insert D A' A a1 b1 c1 A_01 sum_two_rw a_def b_def c_def,
unfold scalar_prod_def Matrix.row_def col_def D_def A'_def,
auto simp add: sum_two_rw less_Suc_eq numerals(2))
have "1∈ ideal_generated{a1,b1,c1}" using i2 by (simp add: ideal_generated_in)
from this obtain f where d: "(∑i∈{a1,b1,c1}. f i * i) = 1"
using ideal_explicit2[of "{a1,b1,c1}"] by auto
from this obtain x y z where "x*a1+y*b1+z*c1 = 1"
using sum_three_elements[of _ a1 b1 c1] by metis
hence xa1_yb1_zc1_dvd_1: "x * a1 + y * b1 + z * c1 dvd 1" by auto
obtain p q where i3: "ideal_generated {p*a1,p*b1+q*c1} = ideal_generated {1}"
using D' i2 by blast
have "ideal_generated {p,q} = UNIV"
proof -
obtain X Y where e: "X*p*a1 + Y*(p*b1+q*c1) = 1"
by (metis i3 ideal_generated_1 ideal_generated_pair_exists_UNIV mult.assoc)
have "X*p*a1 + Y*(p*b1+q*c1) = X*p*a1 + Y*p*b1+Y*q*c1"
by (simp add: add.assoc mult.assoc semiring_normalization_rules(34))
also have "... = (X*a1+Y*b1) * p + (Y * c1) * q"
by (simp add: mult.commute ring_class.ring_distribs)
finally have "(X*a1+Y*b1) * p + Y * c1 * q = 1" using e by simp
from this show ?thesis by (rule ideal_generated_pair_UNIV, simp)
qed
from this obtain u v where pu_qv_1: "p*u - q * v = 1"
by (metis Groups.mult_ac(2) diff_minus_eq_add ideal_generated_1
ideal_generated_pair_exists_UNIV mult_minus_left)
let ?P = "Matrix.mat 2 2 (λ(i,j). if i = 0 ∧ j = 0 then p else
if i = 1 ∧ j = 0 then q else
if i = 0 ∧ j = 1 then v else u)"
have P: "?P ∈ carrier_mat 2 2" by auto
have "Determinant.det ?P = 1" using pu_qv_1 unfolding det_2[OF P] by (simp add: mult.commute)
hence inv_P: "invertible_mat ?P"
by (metis (no_types, lifting) P dvd_refl invertible_iff_is_unit_JNF)
define S1 where "S1 = A'*?P"
have S1: "S1 ∈ carrier_mat 2 2" using A' P S1_def mult_carrier_mat by blast
have S1_00: "S1 $$(0,0) = p*a1" and S1_01: "S1 $$(1,0) = p*b1+q*c1"
unfolding S1_def times_mat_def scalar_prod_def using A' P BU U B
unfolding A'_def upper_triangular_def
by (auto, unfold sum_two_rw, auto simp add: A'_def a_def b_def c_def)
obtain q00 and q01 where q00_q01: "p*a1*q00 + (p*b1+q*c1)*q01 = 1" using i3
by (metis ideal_generated_1 ideal_generated_pair_exists_pq1 mult.commute)
define q10 where "q10 = - (p*b1+q*c1)"
define q11 where "q11 = p*a1"
have q10_q11: "p*a1*q10 + (p*b1+q*c1)*q11 = 0" unfolding q10_def q11_def
by (auto simp add: Rings.ring_distribs(1) Rings.ring_distribs(4) semiring_normalization_rules(7))
let ?Q = "Matrix.mat 2 2 (λ(i,j). if i = 0 ∧ j = 0 then q00 else
if i = 1 ∧ j = 0 then q10 else
if i = 0 ∧ j = 1 then q01 else q11)"
have Q: "?Q ∈ carrier_mat 2 2" by auto
have "Determinant.det ?Q = 1" using q00_q01 unfolding det_2[OF Q] unfolding q10_def q11_def
by (auto, metis (no_types, lifting) add_uminus_conv_diff diff_minus_eq_add more_arith_simps(7)
more_arith_simps(9) mult.commute)
hence inv_Q: "invertible_mat ?Q" by (smt Q dvd_refl invertible_iff_is_unit_JNF)
define S2 where "S2 = ?Q * S1 "
have S2: "S2 ∈ carrier_mat 2 2" using A' P S2_def S1 Q mult_carrier_mat by blast
have S2_00: "S2 $$ (0,0) = 1" unfolding mat_mult2_00[OF Q S1 S2_def] using q00_q01
unfolding S1_00 S1_01 by (simp add: mult.commute)
have S2_10: "S2 $$ (1,0) = 0" unfolding mat_mult2_10[OF Q S1 S2_def]
using q10_q11 unfolding S1_00 S1_01 by (simp add: Groups.mult_ac(2))
let ?P1 ="(addrow_mat 2 (- (S2$$(0,1))) 0 1)"
have P1: "?P1 ∈ carrier_mat 2 2" by auto
have inv_P1: "invertible_mat ?P1"
by (metis addrow_mat_carrier arithmetic_simps(78) det_addrow_mat dvd_def
invertible_iff_is_unit_JNF numeral_One zero_neq_numeral)
define S3 where "S3 = S2 * ?P1"
have P1_P_A': " A' *?P *?P1 ∈ carrier_mat 2 2" using P1 P A' mult_carrier_mat by auto
have S3: "S3 ∈ carrier_mat 2 2" using P1 S2 S3_def mult_carrier_mat by blast
have S3_00: "S3 $$ (0,0) = 1" using S2_00 unfolding mat_mult2_00[OF S2 P1 S3_def] by auto
moreover have S3_01: "S3 $$ (0,1) = 0" using S2_00 unfolding mat_mult2_01[OF S2 P1 S3_def] by auto
moreover have S3_10: "S3 $$ (1,0) = 0" using S2_10 unfolding mat_mult2_10[OF S2 P1 S3_def] by auto
ultimately have SNF_S3: "Smith_normal_form_mat S3"
using S3 unfolding Smith_normal_form_mat_def isDiagonal_mat_def
using less_2_cases by auto
hence SNF_S3_D: "Smith_normal_form_mat (S3*D)"
using D_def S3 SNF_preserved_multiples_identity by blast
have "S3 * D = ?Q * A' * ?P * ?P1 * D" using S1_def S2_def S3_def
by (smt A' P Q S1 addrow_mat_carrier assoc_mult_mat)
also have "... = ?Q * A' * ?P * (?P1 * D)"
by (meson A' D addrow_mat_carrier assoc_mult_mat mat_carrier mult_carrier_mat)
also have "... = ?Q * A' * ?P * (D * ?P1)"
using commute_multiples_identity[OF P1] unfolding D_def by auto
also have "... = ?Q * A' * (?P * (D * ?P1))"
by (smt A' D assoc_mult_mat carrier_matD(1) carrier_matD(2) mat_carrier times_mat_def)
also have "... = ?Q * A' * (D * (?P * ?P1))"
by (smt D D_def P P1 assoc_mult_mat commute_multiples_identity)
also have "... = ?Q * (A' * D) * (?P * ?P1)"
by (smt A' D assoc_mult_mat carrier_matD(1) carrier_matD(2) mat_carrier times_mat_def)
also have "... = ?Q * A * (?P * ?P1)" unfolding A_A'D by auto
also have "... = ?Q * B * (U * (?P * ?P1))" unfolding A_def
by (smt B U assoc_mult_mat carrier_matD(1) carrier_matD(2) mat_carrier times_mat_def)
finally have S3_D_rw: "S3 * D = ?Q * B * (U * (?P * ?P1))" .
show "admits_diagonal_reduction B"
proof (rule admits_diagonal_reduction_intro[OF _ _ inv_Q])
show "(U* (?P * ?P1)) ∈ carrier_mat (dim_col B) (dim_col B)" using B U by auto
show "?Q ∈ carrier_mat (dim_row B) (dim_row B)" using Q B by auto
show "invertible_mat (U * (?P * ?P1))"
by (metis (no_types, lifting) P1 U carrier_matD(1) carrier_matD(2) inv_P inv_P1 inv_U
invertible_mult_JNF mat_carrier times_mat_def)
show "Smith_normal_form_mat (?Q * B *(U* (?P * ?P1)))" using SNF_S3_D S3_D_rw by simp
qed
qed
obtain Smith_1x2 where Smith_1x2: "∀(A::'a mat)∈carrier_mat 1 2. is_SNF A (Smith_1x2 A)"
using admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all[OF admits_1x2] by auto
from this obtain Smith_1x2'
where Smith_1x2': "∀(A::'a mat)∈carrier_mat 1 2. is_SNF A (1⇩m 1, Smith_1x2' A)"
using Smith_1xn_two_matrices_all[OF Smith_1x2] by auto
obtain Smith_2x2 where Smith_2x2: "∀(A::'a mat)∈carrier_mat 2 2. is_SNF A (Smith_2x2 A)"
using admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all[OF admits_2x2] by auto
have d: "is_div_op (λa b. (SOME k. k * b = a))" using div_op_SOME by auto
interpret Smith_Impl Smith_1x2' Smith_2x2 "(λa b. (SOME k. k * b = a))"
using Smith_1x2' Smith_2x2 d by (unfold_locales, auto)
show ?thesis using is_SNF_Smith_mxn
by (meson admits_diagonal_reduction_eq_exists_algorithm_is_SNF carrier_mat_triv)
qed
subsection ‹Final theorem›
theorem edr_characterization:
"(∀(A::'a mat). admits_diagonal_reduction A) = ((∀(A::'a mat). admits_triangular_reduction A)
∧ (∀a b c::'a. ideal_generated{a,b,c} = ideal_generated{1}
⟶ (∃p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})))"
using necessity sufficiency by blast
corollary OFCLASS_edr_characterization:
"OFCLASS('a, elementary_divisor_ring_class) ≡ (OFCLASS('a, Hermite_ring_class)
&&& (∀a b c::'a. ideal_generated{a,b,c} = ideal_generated{1}
⟶ (∃p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})))" (is "?lhs ≡ ?rhs")
proof
assume 1: "OFCLASS('a, elementary_divisor_ring_class)"
hence admits_diagonal: "∀A::'a mat. admits_diagonal_reduction A"
using conjunctionD2[OF 1[unfolded elementary_divisor_ring_class_def]]
unfolding class.elementary_divisor_ring_def by auto
have "∀A::'a mat. admits_triangular_reduction A" by (simp add: admits_diagonal necessity(1))
hence OFCLASS_Hermite: "OFCLASS('a, Hermite_ring_class)" by (intro_classes, simp)
moreover have "∀a b c::'a. ideal_generated {a, b, c} = ideal_generated {1}
⟶ (∃p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})"
using admits_diagonal necessity(2) by blast
ultimately show "OFCLASS('a, Hermite_ring_class) &&&
∀a b c::'a. ideal_generated {a, b, c} = ideal_generated {1}
⟶ (∃p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})"
by auto
next
assume 1: "OFCLASS('a, Hermite_ring_class) &&&
∀a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} ⟶
(∃p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})"
have H: "OFCLASS('a, Hermite_ring_class)"
and 2: "∀a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} ⟶
(∃p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})"
using conjunctionD1[OF 1] conjunctionD2[OF 1] by auto
have "∀A::'a mat. admits_triangular_reduction A"
using H unfolding OFCLASS_Hermite_ring_def by auto
hence a: "∀A::'a mat. admits_diagonal_reduction A" using 2 sufficiency by blast
show "OFCLASS('a, elementary_divisor_ring_class)" by (intro_classes, simp add: a)
qed
corollary edr_characterization_class:
"class.elementary_divisor_ring TYPE('a)
= (class.Hermite_ring TYPE('a)
∧ (∀a b c::'a. ideal_generated{a,b,c} = ideal_generated{1}
⟶ (∃p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})))" (is "?lhs = (?H ∧ ?D')")
proof
assume 1: ?lhs
hence admits_diagonal: "∀A::'a mat. admits_diagonal_reduction A"
unfolding class.elementary_divisor_ring_def .
have admits_triangular: "∀A::'a mat. admits_triangular_reduction A"
using 1 necessity(1) unfolding class.elementary_divisor_ring_def by blast
hence "?H" unfolding class.Hermite_ring_def by auto
moreover have "?D'" using admits_diagonal necessity(2) by blast
ultimately show "(?H ∧ ?D')" by simp
next
assume HD': "(?H ∧ ?D')"
hence admits_triangular: "∀A::'a mat. admits_triangular_reduction A"
unfolding class.Hermite_ring_def by auto
hence admits_diagonal: "∀A::'a mat. admits_diagonal_reduction A"
using edr_characterization HD' by auto
thus ?lhs unfolding class.elementary_divisor_ring_def by auto
qed
corollary edr_iff_T_D':
shows "class.elementary_divisor_ring TYPE('a) = (
(∀a b::'a. ∃ a1 b1 d. a = a1*d ∧ b = b1*d ∧ ideal_generated {a1,b1} = ideal_generated {1})
∧ (∀a b c::'a. ideal_generated{a,b,c} = ideal_generated{1}
⟶ (∃p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1}))
)" (is "?lhs = (?T ∧ ?D')")
proof
assume 1: ?lhs
hence "∀A::'a mat. admits_triangular_reduction A"
unfolding class.elementary_divisor_ring_def using necessity(1) by blast
hence "?T" using theorem3_part2 by simp
moreover have "?D'" using 1 unfolding edr_characterization_class by auto
ultimately show "(?T ∧ ?D')" by simp
next
assume TD': "(?T ∧ ?D')"
hence "class.Hermite_ring TYPE('a)"
unfolding class.Hermite_ring_def using theorem3_part1 TD' by auto
thus ?lhs using edr_characterization_class TD' by auto
qed
end
end
Theory SNF_Algorithm_Euclidean_Domain
section ‹Executable Smith normal form algorithm over Euclidean domains›
theory SNF_Algorithm_Euclidean_Domain
imports
Diagonal_To_Smith
Echelon_Form.Examples_Echelon_Form_Abstract
Elementary_Divisor_Rings
Diagonal_To_Smith_JNF
Mod_Type_Connect
Show.Show_Instances
Jordan_Normal_Form.Show_Matrix
Show.Show_Poly
begin
text ‹This provides an executable implementation of the verified general algorithm, provinding
executable operations over a Euclidean domain.›
lemma zero_less_one_type2: "(0::2) < 1"
proof -
have "Mod_Type.from_nat 0 = (0::2)" by (simp add: from_nat_0)
moreover have "Mod_Type.from_nat 1 = (1::2)" using from_nat_1 by blast
moreover have "(Mod_Type.from_nat 0::2) < Mod_Type.from_nat 1" by (rule from_nat_mono, auto)
ultimately show ?thesis by simp
qed
subsection ‹Previous code equations›
definition "to_hma⇩m_row A i
= (vec_lambda (λj. A $$ (Mod_Type.to_nat i, Mod_Type.to_nat j)))"
lemma bezout_matrix_row_code [code abstract]:
"vec_nth (to_hma⇩m_row A i) =
(λj. A $$ (Mod_Type.to_nat i, Mod_Type.to_nat j))"
unfolding to_hma⇩m_row_def by auto
lemma [code abstract]: "vec_nth (Mod_Type_Connect.to_hma⇩m A) = to_hma⇩m_row A"
unfolding Mod_Type_Connect.to_hma⇩m_def unfolding to_hma⇩m_row_def[abs_def]
by auto
subsection ‹An executable algorithm to transform $2 \times 2$ matrices into its Smith normal form
in HOL Analysis›
subclass (in euclidean_ring_gcd) bezout_ring_div
proof qed
context
fixes bezout::"('a::euclidean_ring_gcd ⇒ 'a ⇒ ('a×'a×'a×'a×'a))"
assumes ib: "is_bezout_ext bezout"
begin
lemma normalize_bezout_gcd:
assumes b: "(p,q,u,v,d) = bezout a b"
shows "normalize d = gcd a b"
proof -
let ?gcd = "(λa b. case bezout a b of (x, xa,u,v, gcd') ⇒ gcd')"
have is_gcd: "is_gcd ?gcd" by (simp add: ib is_gcd_is_bezout_ext)
have "(?gcd a b) = d" using b by (metis case_prod_conv)
moreover have "normalize (?gcd a b) = normalize (gcd a b)"
proof (rule associatedI)
show "(?gcd a b) dvd (gcd a b)" using is_gcd is_gcd_def by fastforce
show "(gcd a b) dvd (?gcd a b)" by (metis (no_types) gcd_dvd1 gcd_dvd2 is_gcd is_gcd_def)
qed
ultimately show ?thesis by auto
qed
end
lemma bezout_matrix_works_transpose1:
assumes ib: "is_bezout_ext bezout"
and a_not_b: "a ≠ b"
shows "(A**transpose (bezout_matrix (transpose A) a b i bezout)) $ i $ a
= snd (snd (snd (snd (bezout (A $ i $ a) (A $ i $ b)))))"
proof -
have "(A**transpose (bezout_matrix (transpose A) a b i bezout)) $h i $h a
= transpose (A**transpose (bezout_matrix (transpose A) a b i bezout)) $h a $h i"
by (simp add: transpose_code transpose_row_code)
also have "... = ((bezout_matrix (transpose A) a b i bezout) ** (transpose A)) $h a $h i"
by (simp add: matrix_transpose_mul)
also have "... = snd (snd (snd (snd (bezout ((transpose A) $ a $ i) ((transpose A) $ b $ i)))))"
by (rule bezout_matrix_works1[OF ib a_not_b])
also have "... = snd (snd (snd (snd (bezout (A $ i $ a) (A $ i $ b)))))"
by (simp add: transpose_code transpose_row_code)
finally show ?thesis .
qed
lemma invertible_bezout_matrix_transpose:
fixes A::"'a::{bezout_ring_div}^'cols::{finite,wellorder}^'rows"
assumes ib: "is_bezout_ext bezout"
and a_less_b: "a < b"
and aj: "A $h i $h a ≠ 0"
shows "invertible (transpose (bezout_matrix (transpose A) a b i bezout))"
proof -
have "Determinants.det (bezout_matrix (transpose A) a b i bezout) = 1"
by (rule det_bezout_matrix[OF ib a_less_b], insert aj, auto simp add: transpose_def)
hence "Determinants.det (transpose (bezout_matrix (transpose A) a b i bezout)) = 1" by simp
thus ?thesis by (simp add: invertible_iff_is_unit)
qed
function diagonalize_2x2_aux :: "(('a::euclidean_ring_gcd^2^2) × ('a^2^2)×('a^2^2)) ⇒
(('a^2^2) ×('a^2^2)×('a^2^2))"
where "diagonalize_2x2_aux (P,A,Q) =
(
let
a = A $h 0 $h 0;
b = A $h 0 $h 1;
c = A $h 1 $h 0;
d = A $h 1 $h 1 in
if a≠ 0 ∧ ¬ a dvd b then let bezout_mat = transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2) in
diagonalize_2x2_aux (P, A**bezout_mat,Q**bezout_mat) else
if a ≠ 0 ∧ ¬ a dvd c then let bezout_mat = bezout_matrix A 0 1 0 euclid_ext2
in diagonalize_2x2_aux (bezout_mat**P,bezout_mat**A,Q) else
let Q' = column_add (Finite_Cartesian_Product.mat 1) 1 0 (- (b div a));
P' = row_add (Finite_Cartesian_Product.mat 1) 1 0 (- (c div a)) in
(P'**P,P'**A**Q',Q**Q')
)" by auto
termination
proof-
have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
have "euclidean_size ((bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0) < euclidean_size (A $h 0 $h 0)"
if a_not_dvd_c: "¬ A $h 0 $h 0 dvd A $h 1 $h 0" and a_not0: "A $h 0 $h 0 ≠ 0" for A::"'a^2^2"
proof-
let ?a = "(A $h 0 $h 0)" let ?c = "(A $h 1 $h 0)"
obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 ?a ?c" by (metis prod_cases5)
have "(bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0 = d"
by (metis bezout_matrix_works1 ib one_neq_zero pquvd prod.sel(2))
hence "normalize ((bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0) = normalize d" by auto
also have "... = gcd ?a ?c" by (rule normalize_bezout_gcd[OF ib pquvd])
finally have "euclidean_size ((bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0)
= euclidean_size (gcd ?a ?c)" by (metis euclidean_size_normalize)
also have "... < euclidean_size ?a" by (rule euclidean_size_gcd_less1[OF a_not0 a_not_dvd_c])
finally show ?thesis .
qed
moreover have "euclidean_size ((A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0)
< euclidean_size (A $h 0 $h 0)"
if a_not_dvd_b: "¬ A $h 0 $h 0 dvd A $h 0 $h 1" and a_not0: "A $h 0 $h 0 ≠ 0" for A::"'a^2^2"
proof-
let ?a = "(A $h 0 $h 0)" let ?b = "(A $h 0 $h 1)"
obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 ?a ?b" by (metis prod_cases5)
have "(A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0 = d"
by (metis bezout_matrix_works_transpose1 ib pquvd prod.sel(2) zero_neq_one)
hence "normalize ((A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0) = normalize d" by auto
also have "... = gcd ?a ?b" by (rule normalize_bezout_gcd[OF ib pquvd])
finally have "euclidean_size ((A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0)
= euclidean_size (gcd ?a ?b)" by (metis euclidean_size_normalize)
also have "... < euclidean_size ?a" by (rule euclidean_size_gcd_less1[OF a_not0 a_not_dvd_b])
finally show ?thesis .
qed
ultimately show ?thesis
by (relation "Wellfounded.measure (λ(P,A,Q). euclidean_size (A $h 0 $h 0))", auto)
qed
lemma diagonalize_2x2_aux_works:
assumes "A = P ** A_input ** Q"
and "invertible P" and "invertible Q"
and "(P',D,Q') = diagonalize_2x2_aux (P,A,Q)"
and "A $h 0 $h 0 ≠ 0"
shows "D = P' ** A_input ** Q' ∧ invertible P' ∧ invertible Q' ∧ isDiagonal D"
using assms
proof (induct "(P,A,Q)" arbitrary: P A Q rule: diagonalize_2x2_aux.induct)
case (1 P A Q)
let ?a = "A $h 0 $h 0"
let ?b = "A $h 0 $h 1"
let ?c = "A $h 1 $h 0"
let ?d = "A $h 1 $h 1"
have a_not_0: "?a ≠ 0" using "1.prems" by blast
have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
have one_not_zero: "1 ≠ (0::2)" by auto
show ?case
proof (cases "¬ ?a dvd ?b")
case True
let ?bezout_mat_right = "transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)"
have "(P', D, Q') = diagonalize_2x2_aux (P, A, Q)" using "1.prems" by blast
also have "... = diagonalize_2x2_aux (P, A** ?bezout_mat_right, Q ** ?bezout_mat_right)"
using True a_not_0 by (auto simp add: Let_def)
finally have eq: "(P',D,Q') = ..." .
show ?thesis
proof (rule "1.hyps"(1)[OF _ _ _ _ _ _ _ _ _ eq])
have "invertible ?bezout_mat_right"
by (rule invertible_bezout_matrix_transpose[OF ib zero_less_one_type2 a_not_0])
thus "invertible (Q ** ?bezout_mat_right)"
using "1.prems" invertible_mult by blast
show "A ** ?bezout_mat_right = P ** A_input ** (Q ** ?bezout_mat_right)"
by (simp add: "1.prems" matrix_mul_assoc)
show "(A ** ?bezout_mat_right) $h 0 $h 0 ≠ 0"
by (metis (no_types, lifting) a_not_0 bezout_matrix_works_transpose1 bezout_matrix_not_zero
bezout_matrix_works1 is_bezout_ext_euclid_ext2 one_neq_zero transpose_code transpose_row_code)
qed (insert True a_not_0 "1.prems", blast+)
next
case False note a_dvd_b = False
show ?thesis
proof (cases "¬ ?a dvd ?c")
case True
let ?bezout_mat = "(bezout_matrix A 0 1 0 euclid_ext2)"
have "(P', D, Q') = diagonalize_2x2_aux (P, A, Q)" using "1.prems" by blast
also have "... = diagonalize_2x2_aux (?bezout_mat**P, ?bezout_mat ** A, Q)"
using True a_dvd_b a_not_0 by (auto simp add: Let_def)
finally have eq: "(P',D,Q') = ..." .
show ?thesis
proof (rule "1.hyps"(2)[OF _ _ _ _ _ _ _ _ _ _ eq])
have "invertible ?bezout_mat"
by (rule invertible_bezout_matrix[OF ib zero_less_one_type2 a_not_0])
thus "invertible (?bezout_mat ** P)"
using "1.prems" invertible_mult by blast
show "?bezout_mat ** A = (?bezout_mat ** P) ** A_input ** Q"
by (simp add: "1.prems" matrix_mul_assoc)
show "(?bezout_mat ** A) $h 0 $h 0 ≠ 0"
by (simp add: a_not_0 bezout_matrix_not_zero is_bezout_ext_euclid_ext2)
qed (insert True a_not_0 a_dvd_b "1.prems", blast+)
next
case False
hence a_dvd_c: "?a dvd ?c" by simp
let ?Q' = "column_add (Finite_Cartesian_Product.mat 1) 1 0 (- (?b div ?a))::'a^2^2"
let ?P' = "(row_add (Finite_Cartesian_Product.mat 1) 1 0 (- (?c div ?a)))::'a^2^2"
have eq: "(P', D, Q') = (?P'**P,?P'**A**?Q',Q**?Q')"
using "1.prems" a_dvd_b a_dvd_c a_not_0 by (auto simp add: Let_def)
have d: "isDiagonal (?P'**A**?Q')"
proof -
{
fix a b::2 assume a_not_b: "a ≠ b"
have "(?P' ** A ** ?Q') $h a $h b = 0"
proof (cases "(a,b) = (0,1)")
case True
hence a0: "a = 0" and b1: "b = 1" by auto
have "(?P' ** A ** ?Q') $h a $h b = (?P' ** (A ** ?Q')) $h a $h b"
by (simp add: matrix_mul_assoc)
also have "... = (A**?Q') $h a $h b" unfolding row_add_mat_1
by (smt True a_not_b prod.sel(2) row_add_def vec_lambda_beta)
also have "... = 0" unfolding column_add_mat_1 a0 b1
by (smt Groups.mult_ac(2) a_dvd_b ab_group_add_class.ab_left_minus add_0_left
add_diff_cancel_left' add_uminus_conv_diff column_add_code_nth column_add_row_def
comm_semiring_class.distrib dvd_div_mult_self vec_lambda_beta)
finally show ?thesis .
next
case False
hence a1: "a = 1" and b0: "b = 0"
by (metis (no_types, hide_lams) False a_not_b exhaust_2 zero_neq_one)+
have "(?P' ** A ** ?Q') $h a $h b = (?P' ** A) $h a $h b"
unfolding a1 b0 column_add_mat_1
by (simp add: column_add_code_nth column_add_row_def)
also have "... = 0" unfolding row_add_mat_1 a1 b0
by (simp add: a_dvd_c row_add_def)
finally show ?thesis .
qed}
thus ?thesis unfolding isDiagonal_def by auto
qed
have inv_P': "invertible ?P'" by (rule invertible_row_add[OF one_not_zero])
have inv_Q': "invertible ?Q'" by (rule invertible_column_add[OF one_not_zero])
have "invertible (?P'**P)" using "1.prems"(2) inv_P' invertible_mult by blast
moreover have "invertible (Q**?Q')" using "1.prems"(3) inv_Q' invertible_mult by blast
moreover have "D = P' ** A_input ** Q'"
by (metis (no_types, lifting) "1.prems"(1) Pair_inject eq matrix_mul_assoc)
ultimately show ?thesis using eq d by auto
qed
qed
qed
definition "diagonalize_2x2 A =
(if A $h 0 $h 0 = 0 then
if A $h 0 $h 1 ≠ 0 then
let A' = interchange_columns A 0 1;
Q' = interchange_columns (Finite_Cartesian_Product.mat 1) 0 1 in
diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1, A', Q')
else
if A $h 1 $h 0 ≠ 0 then
let A' = interchange_rows A 0 1;
P' = interchange_rows (Finite_Cartesian_Product.mat 1) 0 1 in
diagonalize_2x2_aux (P', A', Finite_Cartesian_Product.mat 1)
else (Finite_Cartesian_Product.mat 1,A,Finite_Cartesian_Product.mat 1)
else diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1,A,Finite_Cartesian_Product.mat 1)
)"
lemma diagonalize_2x2_works:
assumes PDQ: "(P,D,Q) = diagonalize_2x2 A"
shows "D = P ** A ** Q ∧ invertible P ∧ invertible Q ∧ isDiagonal D"
proof -
let ?a = "A $h 0 $h 0"
let ?b = "A $h 0 $h 1"
let ?c = "A $h 1 $h 0"
let ?d = "A $h 1 $h 1"
show ?thesis
proof (cases "?a = 0")
case False
hence eq: "(P,D,Q) = diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1,A,Finite_Cartesian_Product.mat 1)"
using PDQ unfolding diagonalize_2x2_def by auto
show ?thesis
by (rule diagonalize_2x2_aux_works[OF _ _ _ eq False], auto simp add: invertible_mat_1)
next
case True note a0 = True
show ?thesis
proof (cases "?b ≠ 0")
case True
let ?A' = "interchange_columns A 0 1"
let ?Q' = "(interchange_columns (Finite_Cartesian_Product.mat 1) 0 1)::'a^2^2"
have eq: "(P,D,Q) = diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1, ?A', ?Q')"
using PDQ a0 True unfolding diagonalize_2x2_def by (auto simp add: Let_def)
show ?thesis
proof (rule diagonalize_2x2_aux_works[OF _ _ _ eq _])
show "?A' $h 0 $h 0 ≠ 0"
by (simp add: True interchange_columns_code interchange_columns_code_nth)
show "invertible ?Q'" by (simp add: invertible_interchange_columns)
show "?A' = Finite_Cartesian_Product.mat 1 ** A ** ?Q'"
by (simp add: interchange_columns_mat_1)
qed (auto simp add: invertible_mat_1)
next
case False note b0 = False
show ?thesis
proof (cases "?c ≠ 0")
case True
let ?A' = "interchange_rows A 0 1"
let ?P' = "(interchange_rows (Finite_Cartesian_Product.mat 1) 0 1)::'a^2^2"
have eq: "(P,D,Q) = diagonalize_2x2_aux (?P', ?A',Finite_Cartesian_Product.mat 1)"
using PDQ a0 b0 True unfolding diagonalize_2x2_def by (auto simp add: Let_def)
show ?thesis
proof (rule diagonalize_2x2_aux_works[OF _ _ _ eq _])
show "?A' $h 0 $h 0 ≠ 0"
by (simp add: True interchange_columns_code interchange_columns_code_nth)
show "invertible ?P'" by (simp add: invertible_interchange_rows)
show "?A' = ?P' ** A ** Finite_Cartesian_Product.mat 1"
by (simp add: interchange_rows_mat_1)
qed (auto simp add: invertible_mat_1)
next
case False
have eq: "(P,D,Q) = (Finite_Cartesian_Product.mat 1, A,Finite_Cartesian_Product.mat 1)"
using PDQ a0 b0 True False unfolding diagonalize_2x2_def by (auto simp add: Let_def)
have "isDiagonal A" unfolding isDiagonal_def using a0 b0 True False
by (metis (full_types) exhaust_2 one_neq_zero)
thus ?thesis using invertible_mat_1 eq by auto
qed
qed
qed
qed
definition "diagonalize_2x2_JNF (A::'a::euclidean_ring_gcd mat)
= (let (P,D,Q) = diagonalize_2x2 (Mod_Type_Connect.to_hma⇩m A::'a^2^2) in
(Mod_Type_Connect.from_hma⇩m P,Mod_Type_Connect.from_hma⇩m D,Mod_Type_Connect.from_hma⇩m Q))"
lemma diagonalize_2x2_JNF_works:
assumes A: "A ∈ carrier_mat 2 2"
and PDQ: "(P,D,Q) = diagonalize_2x2_JNF A"
shows "D = P * A * Q ∧ invertible_mat P ∧ invertible_mat Q ∧ isDiagonal_mat D ∧ P∈carrier_mat 2 2
∧ Q ∈ carrier_mat 2 2 ∧ D ∈ carrier_mat 2 2"
proof -
let ?A = "(Mod_Type_Connect.to_hma⇩m A::'a^2^2)"
have A[transfer_rule]: "Mod_Type_Connect.HMA_M A ?A"
using A unfolding Mod_Type_Connect.HMA_M_def by auto
obtain P_HMA D_HMA Q_HMA where PDQ_HMA: "(P_HMA,D_HMA,Q_HMA) = diagonalize_2x2 ?A"
by (metis prod_cases3)
have P: "P = Mod_Type_Connect.from_hma⇩m P_HMA" and Q: "Q = Mod_Type_Connect.from_hma⇩m Q_HMA"
and D: "D = Mod_Type_Connect.from_hma⇩m D_HMA"
using PDQ_HMA PDQ unfolding diagonalize_2x2_JNF_def
by (metis prod.simps(1) split_conv)+
have [transfer_rule]: "Mod_Type_Connect.HMA_M P P_HMA"
unfolding Mod_Type_Connect.HMA_M_def using P by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_M Q Q_HMA"
unfolding Mod_Type_Connect.HMA_M_def using Q by auto
have [transfer_rule]: "Mod_Type_Connect.HMA_M D D_HMA"
unfolding Mod_Type_Connect.HMA_M_def using D by auto
have r: "D_HMA = P_HMA ** ?A ** Q_HMA ∧ invertible P_HMA ∧ invertible Q_HMA ∧ isDiagonal D_HMA"
by (rule diagonalize_2x2_works[OF PDQ_HMA])
have "D = P * A * Q ∧ invertible_mat P ∧ invertible_mat Q ∧ isDiagonal_mat D"
using r by (transfer, rule)
thus ?thesis using P Q D by auto
qed
definition "Smith_2x2_eucl A = (
let (P,D,Q) = diagonalize_2x2 A;
(P',S,Q') = diagonal_to_Smith_PQ D euclid_ext2
in (P' ** P, S, Q ** Q'))"
lemma Smith_2x2_eucl_works:
assumes PBQ: "(P,S,Q) = Smith_2x2_eucl A"
shows "S = P ** A ** Q ∧ invertible P ∧ invertible Q ∧ Smith_normal_form S"
proof -
have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
obtain P1 D Q1 where P1DQ1: "(P1,D,Q1) = diagonalize_2x2 A" by (metis prod_cases3)
obtain P2 S' Q2 where P2SQ2:"(P2,S',Q2) = diagonal_to_Smith_PQ D euclid_ext2"
by (metis prod_cases3)
have P: "P = P2 ** P1" and S: "S = S'" and Q: "Q = Q1 ** Q2"
by (metis (mono_tags, lifting) PBQ Pair_inject Smith_2x2_eucl_def P1DQ1 P2SQ2 old.prod.case)+
have 1: "D = P1 ** A ** Q1 ∧ invertible P1 ∧ invertible Q1 ∧ isDiagonal D"
by (rule diagonalize_2x2_works[OF P1DQ1])
have 2: "S' = P2 ** D ** Q2 ∧ invertible P2 ∧ invertible Q2 ∧ Smith_normal_form S'"
by (rule diagonal_to_Smith_PQ'[OF _ ib P2SQ2], insert 1, auto)
show ?thesis using 1 2 P S Q by (simp add: 2 invertible_mult matrix_mul_assoc)
qed
subsection ‹An executable algorithm to transform $2 \times 2$ matrices into its Smith normal form
in JNF›
definition "Smith_2x2_JNF_eucl A = (
let (P,D,Q) = diagonalize_2x2_JNF A;
(P',S,Q') = diagonal_to_Smith_PQ_JNF D euclid_ext2
in (P' * P, S, Q * Q'))"
lemma Smith_2x2_JNF_eucl_works:
assumes A: "A ∈ carrier_mat 2 2"
and PBQ: "(P,S,Q) = Smith_2x2_JNF_eucl A"
shows "is_SNF A (P,S,Q)"
proof -
have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
obtain P1 D Q1 where P1DQ1: "(P1,D,Q1) = diagonalize_2x2_JNF A" by (metis prod_cases3)
obtain P2 S' Q2 where P2SQ2: "(P2,S',Q2) = diagonal_to_Smith_PQ_JNF D euclid_ext2"
by (metis prod_cases3)
have P: "P = P2 * P1" and S: "S = S'" and Q: "Q = Q1 * Q2"
by (metis (mono_tags, lifting) PBQ Pair_inject Smith_2x2_JNF_eucl_def P1DQ1 P2SQ2 old.prod.case)+
have 1: "D = P1 * A * Q1 ∧ invertible_mat P1 ∧ invertible_mat Q1 ∧ isDiagonal_mat D
∧ P1 ∈ carrier_mat 2 2 ∧ Q1 ∈ carrier_mat 2 2 ∧ D ∈ carrier_mat 2 2"
by (rule diagonalize_2x2_JNF_works[OF A P1DQ1])
have 2: "S' = P2 * D * Q2 ∧ invertible_mat P2 ∧ invertible_mat Q2 ∧ Smith_normal_form_mat S'
∧ P2 ∈ carrier_mat 2 2 ∧ S' ∈ carrier_mat 2 2 ∧ Q2 ∈ carrier_mat 2 2"
by (rule diagonal_to_Smith_PQ_JNF[OF _ ib _ P2SQ2], insert 1, auto)
show ?thesis
proof (rule is_SNF_intro)
have dim_Q: "Q ∈ carrier_mat 2 2" using Q 1 2 by auto
have P1AQ1: "(P1*A*Q1) ∈ carrier_mat 2 2" using 1 2 A by auto
have rw1: "(P1 * A * Q1) * Q2 = (P1 * A * (Q1 * Q2))"
by (meson "1" "2" A assoc_mult_mat mult_carrier_mat)
have rw2: "(P1 * A * Q) = P1 * (A * Q)" by (rule assoc_mult_mat[OF _ A dim_Q], insert 1, auto)
show "invertible_mat Q" using 1 2 Q invertible_mult_JNF by blast
show "invertible_mat P" using 1 2 P invertible_mult_JNF by blast
have "P2 * D * Q2 = P2 * (P1 * A * Q1) * Q2" using 1 2 by auto
also have "... = P2 * ((P1 * A * Q1) * Q2)" using 1 2 by auto
also have "... = P2 * (P1 * A * (Q1 * Q2))" unfolding rw1 by simp
also have "... = P2 * (P1 * A * Q)" using Q by auto
also have "... = P2 * (P1 * (A * Q))" unfolding rw2 by simp
also have "... = P2 * P1 * (A * Q)" by (rule assoc_mult_mat[symmetric], insert 1 2 A Q, auto)
also have "... = P*(A*Q)" unfolding P by simp
also have "... = P*A*Q" by (rule assoc_mult_mat[symmetric], insert 1 2 A Q P, auto)
finally show "S = P * A * Q" using 1 2 S by auto
qed (insert 1 2 P Q A S, auto)
qed
subsection ‹An executable algorithm to transform $1 \times 2$ matrices into its Smith normal form›
definition "Smith_1x2_eucl (A::'a::euclidean_ring_gcd^2^1) = (
if A $h 0 $h 0 = 0 ∧ A $h 0 $h 1 ≠ 0 then
let Q = interchange_columns (Finite_Cartesian_Product.mat 1) 0 1;
A' = interchange_columns A 0 1 in (A',Q)
else
if A $h 0 $h 0 ≠ 0 ∧ A $h 0 $h 1 ≠ 0 then
let bezout_matrix_right = transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)
in (A ** bezout_matrix_right, bezout_matrix_right)
else (A, Finite_Cartesian_Product.mat 1)
)"
lemma Smith_1x2_eucl_works:
assumes SQ: "(S,Q) = Smith_1x2_eucl A"
shows "S = A ** Q ∧ invertible Q ∧ S $h 0 $h 1 = 0"
proof (cases "A $h 0 $h 0 = 0 ∧ A $h 0 $h 1 ≠ 0")
case True
have Q: "Q = interchange_columns (Finite_Cartesian_Product.mat 1) 0 1"
and S: "S = interchange_columns A 0 1"
using SQ True unfolding Smith_1x2_eucl_def by (auto simp add: Let_def)
have "S $h 0 $h 1 = 0" by (simp add: S True interchange_columns_code interchange_columns_code_nth)
moreover have "invertible Q" using Q invertible_interchange_columns by blast
moreover have "S = A ** Q" by (simp add: Q S interchange_columns_mat_1)
ultimately show ?thesis by simp
next
case False note A00_A01 = False
show ?thesis
proof (cases "A $h 0 $h 0 ≠ 0 ∧ A $h 0 $h 1 ≠ 0")
case True
have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
let ?bezout_matrix_right = "transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)"
have Q: "Q = ?bezout_matrix_right" and S: "S = A**?bezout_matrix_right"
using SQ True A00_A01 unfolding Smith_1x2_eucl_def by (auto simp add: Let_def)
have "invertible Q" unfolding Q
by (rule invertible_bezout_matrix_transpose[OF ib zero_less_one_type2], insert True, auto)
moreover have "S $h 0 $h 1 = 0"
by (smt Finite_Cartesian_Product.transpose_transpose S True bezout_matrix_works2 ib
matrix_transpose_mul rel_simps(92) transpose_code transpose_row_code)
moreover have "S = A**Q" unfolding S Q by simp
ultimately show ?thesis by simp
next
case False
have Q: "Q = (Finite_Cartesian_Product.mat 1)" and S: "S = A"
using SQ False A00_A01 unfolding Smith_1x2_eucl_def by (auto simp add: Let_def)
show ?thesis using False A00_A01 S Q invertible_mat_1 by auto
qed
qed
definition bezout_matrix_JNF :: "'a::comm_ring_1 mat ⇒ nat ⇒ nat ⇒ nat
⇒ ('a ⇒ 'a ⇒ ('a × 'a × 'a × 'a × 'a)) ⇒ 'a mat"
where
"bezout_matrix_JNF A a b j bezout = Matrix.mat (dim_row A) (dim_row A) (λ(x,y).
(let
(p, q, u, v, d) = bezout (A $$ (a, j)) (A $$ (b, j))
in
if x = a ∧ y = a then p else
if x = a ∧ y = b then q else
if x = b ∧ y = a then u else
if x = b ∧ y = b then v else
if x = y then 1 else 0))"
definition "Smith_1x2_eucl_JNF (A::'a::euclidean_ring_gcd mat) = (
if A $$ (0, 0) = 0 ∧ A $$ (0, 1) ≠ 0 then
let Q = swaprows_mat 2 0 1;
A' = swapcols 0 1 A
in (A',Q)
else
if A $$ (0, 0) ≠ 0 ∧ A $$ (0, 1) ≠ 0 then
let bezout_matrix_right = transpose_mat (bezout_matrix_JNF (transpose_mat A) 0 1 0 euclid_ext2)
in (A * bezout_matrix_right, bezout_matrix_right)
else (A, 1⇩m 2)
)"
lemma Smith_1x2_eucl_JNF_works:
assumes A: "A ∈ carrier_mat 1 2"
and SQ: "(S,Q) = Smith_1x2_eucl_JNF A"
shows "is_SNF A (1⇩m 1, (Smith_1x2_eucl_JNF A))"
proof -
have i: "0<dim_row A" and j: "1<dim_col A" using A by auto
have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
show ?thesis
proof (cases "A $$ (0, 0) = 0 ∧ A $$ (0, 1) ≠ 0")
case True
have Q: "Q = swaprows_mat 2 0 1"
and S: "S = swapcols 0 1 A"
using SQ True unfolding Smith_1x2_eucl_JNF_def by (auto simp add: Let_def)
have S01: "S $$ (0,1) = 0" unfolding S using index_mat_swapcols j i True by simp
have dim_S: "S ∈ carrier_mat 1 2" using S A by auto
moreover have dim_Q: "Q ∈ carrier_mat 2 2" using S Q by auto
moreover have "invertible_mat Q"
proof -
have "Determinant.det (swaprows_mat 2 0 1) = -1" by (rule det_swaprows_mat, auto)
also have "... dvd 1" by simp
finally show ?thesis using Q dim_Q invertible_iff_is_unit_JNF by blast
qed
moreover have "S = A * Q" unfolding S Q using A by (simp add: swapcols_mat)
moreover have "Smith_normal_form_mat S" unfolding Smith_normal_form_mat_def isDiagonal_mat_def
using S01 dim_S less_2_cases by fastforce
ultimately show ?thesis using SQ S Q A unfolding is_SNF_def by auto
next
case False note A00_A01 = False
show ?thesis
proof (cases "A $$ (0,0) ≠ 0 ∧ A $$ (0,1) ≠ 0")
case True
have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
let ?BM = "(bezout_matrix_JNF A⇧T 0 1 0 euclid_ext2)⇧T"
have Q: "Q = ?BM" and S: "S = A*?BM"
using SQ True A00_A01 unfolding Smith_1x2_eucl_JNF_def by (auto simp add: Let_def)
let ?a = "A $$ (0, 0)" let ?b = "A $$ (0, Suc 0)"
obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 ?a ?b" by (metis prod_cases5)
have d: "p*?a + q*?b = d" and u: "u = - ?b div d" and v: "v = ?a div d"
using pquvd unfolding euclid_ext2_def using bezout_coefficients_fst_snd by blast+
have da: "d dvd ?a" and db: "d dvd ?b" and gcd_ab: "d = gcd ?a ?b"
by (metis euclid_ext2_def gcd_dvd1 gcd_dvd2 pquvd prod.sel(2))+
have dim_S: "S ∈ carrier_mat 1 2" using S A by (simp add: bezout_matrix_JNF_def)
moreover have dim_Q: "Q ∈ carrier_mat 2 2" using A Q by (simp add: bezout_matrix_JNF_def)
have "invertible_mat Q"
proof -
have "Determinant.det ?BM = ?BM $$ (0, 0) * ?BM $$ (1, 1) - ?BM $$ (0, 1) * ?BM $$ (1, 0)"
by (rule det_2, insert A, auto simp add: bezout_matrix_JNF_def)
also have "... = p * v - u*q"
by (insert i j pquvd, auto simp add: bezout_matrix_JNF_def, metis split_conv)
also have "... = (p * ?a) div d - (q * (-?b)) div d" unfolding v u
by (simp add: da db div_mult_swap mult.commute)
also have "... = (p * ?a + q * ?b) div d"
by (metis (no_types, lifting) da db diff_minus_eq_add div_diff dvd_minus_iff dvd_trans
dvd_triv_right more_arith_simps(8))
also have "... = 1 " unfolding d using True da by fastforce
finally show ?thesis unfolding Q
by (metis (full_types) Determinant.det_def Q carrier_matI invertible_iff_is_unit_JNF
not_is_unit_0 one_dvd)
qed
moreover have S_AQ: "S = A*Q" unfolding S Q by simp
moreover have S01: "S $$ (0,1) = 0"
proof -
have Q01: "Q $$ (0, 1) = u"
proof -
have "?BM $$ (0,1) = (bezout_matrix_JNF A⇧T 0 1 0 euclid_ext2) $$ (1, 0)"
using Q dim_Q by auto
also have "... = (λ(x::nat, y::nat).
let (p, q, u, v, d) = euclid_ext2 (A⇧T $$ (0, 0)) (A⇧T $$ (1, 0)) in if x = 0 ∧ y = 0 then p
else if x = 0 ∧ y = 1 then q else if x = 1 ∧ y = 0 then u else if x = 1 ∧ y = 1 then v
else if x = y then 1 else 0) (1, 0)"
unfolding bezout_matrix_JNF_def by (rule index_mat(1), insert A, auto)
also have "... = u" using pquvd unfolding split_beta Let_def
by (auto, metis A One_nat_def carrier_matD(2) fst_conv i index_transpose_mat(1)
j rel_simps(51) snd_conv)
finally show ?thesis unfolding Q by auto
qed
have Q11: "Q $$ (1, 1) = v"
proof -
have "?BM $$ (1,1) = (bezout_matrix_JNF A⇧T 0 1 0 euclid_ext2) $$ (1, 1)"
using Q dim_Q by auto
also have "... = (λ(x::nat, y::nat).
let (p, q, u, v, d) = euclid_ext2 (A⇧T $$ (0, 0)) (A⇧T $$ (1, 0)) in if x = 0 ∧ y = 0 then p
else if x = 0 ∧ y = 1 then q else if x = 1 ∧ y = 0 then u else if x = 1 ∧ y = 1 then v
else if x = y then 1 else 0) (1, 1)"
unfolding bezout_matrix_JNF_def by (rule index_mat(1), insert A, auto)
also have "... = v" using pquvd unfolding split_beta Let_def
by (auto, metis A One_nat_def carrier_matD(2) fst_conv i index_transpose_mat(1)
j rel_simps(51) snd_conv)
finally show ?thesis unfolding Q by auto
qed
have "S $$ (0,1) = Matrix.row A 0 ∙ col Q 1" using index_mult_mat Q S dim_S i by auto
also have "... = (∑i = 0..<2. Matrix.row A 0 $v i * Q $$ (i, 1))"
unfolding scalar_prod_def using dim_S dim_Q by auto
also have "... = (∑i ∈ {0,1}. Matrix.row A 0 $v i * Q $$ (i, 1))" by (rule sum.cong, auto)
also have "... = Matrix.row A 0 $v 0 * Q $$ (0, 1) + Matrix.row A 0 $v 1 * Q $$ (1, 1)"
using sum_two_elements by auto
also have "... = ?a*u + ?b * v" unfolding Q01 Q11 using i index_row(1) j A by auto
also have "... = 0" unfolding u v
by (smt Groups.mult_ac(2) Groups.mult_ac(3) add.right_inverse add_uminus_conv_diff da db
diff_minus_eq_add dvd_div_mult_self dvd_neg_div minus_mult_left)
finally show ?thesis .
qed
moreover have "Smith_normal_form_mat S"
using less_2_cases S01 dim_S unfolding Smith_normal_form_mat_def isDiagonal_mat_def
by fastforce
ultimately show ?thesis using S Q A SQ unfolding is_SNF_def bezout_matrix_JNF_def by force
next
case False
have Q: "Q = 1⇩m 2" and S: "S = A"
using SQ False A00_A01 unfolding Smith_1x2_eucl_JNF_def by (auto simp add: Let_def)
have "is_SNF A (1⇩m 1, A, 1⇩m 2)"
by (rule is_SNF_intro, insert A False A00_A01 S Q A less_2_cases,
unfold Smith_normal_form_mat_def isDiagonal_mat_def, fastforce+)
thus ?thesis using SQ S Q by auto
qed
qed
qed
subsection ‹The final executable algorithm to transform any matrix into its Smith normal form›
global_interpretation Smith_ED: Smith_Impl Smith_1x2_eucl_JNF Smith_2x2_JNF_eucl "(div)"
defines Smith_ED_1xn_aux = Smith_ED.Smith_1xn_aux
and Smith_ED_nx1 = Smith_ED.Smith_nx1
and Smith_ED_1xn = Smith_ED.Smith_1xn
and Smith_ED_2xn = Smith_ED.Smith_2xn
and Smith_ED_nx2 = Smith_ED.Smith_nx2
and Smith_ED_mxn = Smith_ED.Smith_mxn
proof
show "∀(A::'a mat)∈carrier_mat 1 2. is_SNF A (1⇩m 1, Smith_1x2_eucl_JNF A)"
using Smith_1x2_eucl_JNF_works prod.collapse by blast
show "∀A∈carrier_mat 2 2. is_SNF A (Smith_2x2_JNF_eucl A)"
by (simp add: Smith_2x2_JNF_eucl_def Smith_2x2_JNF_eucl_works split_beta)
show "is_div_op ((div)::'a⇒'a⇒'a::euclidean_ring_gcd)"
by (unfold is_div_op_def, simp)
qed
end
Theory Smith_Certified
section ‹A certified checker based on an external algorithm to compute Smith normal form›
theory Smith_Certified
imports
SNF_Algorithm_Euclidean_Domain
begin
text‹This (unspecified) function takes as input the matrix $A$ and returns five matrices
$(P,S,Q,P',Q')$, which must satisfy $S = PAQ$, $S$ is in Smith normal form, $P'$ and $Q'$
are the inverse matrices of $P$ and $Q$ respectively›
text‹The matrices are given in terms of lists for the sake of simplicity when connecting the
function to external solvers, like Mathematica or Sage.›
consts external_SNF ::
"int list list ⇒ int list list × int list list × int list list × int list list × int list list"
text ‹We implement the checker by means of the following definition. The checker is implemented
in the JNF representation of matrices to make use of the Strassen matrix multiplication algorithm.
In case that the certification fails, then the verified Smith normal form algorithm is executed.
Thus, we will always get a verified result.›
definition "checker_SNF A = (
let A' = mat_to_list A; m = dim_row A; n = dim_col A in
case external_SNF A' of (P_ext,S_ext,Q_ext,P'_ext,Q'_ext) ⇒ let
P = mat_of_rows_list m P_ext;
S = mat_of_rows_list m S_ext;
Q = mat_of_rows_list m Q_ext;
P' = mat_of_rows_list m P'_ext;
Q' = mat_of_rows_list m Q'_ext in
(if dim_row P = m ∧ dim_col P = m
∧ dim_row S = m ∧ dim_col S = n
∧ dim_row Q = n ∧ dim_col Q = n
∧ dim_row P' = m ∧ dim_col P' = m
∧ dim_row Q' = n ∧ dim_col Q' = n
∧ P * P' = 1⇩m m ∧ Q * Q' = 1⇩m n
∧ Smith_normal_form_mat S ∧ (S = P*A*Q) then
(P,S,Q) else Code.abort (STR ''Certification failed'') (λ _. Smith_ED_mxn A))
)"
theorem checker_SNF_soudness:
assumes A: "A ∈ carrier_mat m n"
and c: "checker_SNF A = (P,S,Q)"
shows "is_SNF A (P,S,Q)"
proof -
let ?ext = "external_SNF (mat_to_list A)"
obtain P_ext S_ext Q_ext P'_ext Q'_ext where ext: "?ext = (P_ext,S_ext,Q_ext,P'_ext,Q'_ext)"
by (cases "?ext", auto)
let ?case_external = "let
P = mat_of_rows_list m P_ext;
S = mat_of_rows_list m S_ext;
Q = mat_of_rows_list n Q_ext;
P' = mat_of_rows_list m P'_ext;
Q' = mat_of_rows_list n Q'_ext in
(dim_row P = m ∧ dim_col P = m
∧ dim_row S = m ∧ dim_col S = n
∧ dim_row Q = n ∧ dim_col Q = n
∧ dim_row P' = m ∧ dim_col P' = m
∧ dim_row Q' = n ∧ dim_col Q' = n
∧ P * P' = 1⇩m m ∧ Q * Q' = 1⇩m n
∧ Smith_normal_form_mat S ∧ (S = P*A*Q))"
show ?thesis
proof (cases ?case_external)
case True
define P' where "P' = mat_of_rows_list m P'_ext"
define Q' where "Q' = mat_of_rows_list m Q'_ext"
have S_PAQ: "S = P * A * Q "
and SNF_S: "Smith_normal_form_mat S" and PP'_1: "P * P' = 1⇩m m" and QQ'_1: "Q * Q' = 1⇩m n"
and sm_P: "square_mat P" and sm_Q: "square_mat Q"
using ext True c A
unfolding checker_SNF_def Let_def mat_of_rows_list_def P'_def Q'_def
by (auto split: if_splits)
have inv_P: "invertible_mat P"
proof (unfold invertible_mat_def, rule conjI, rule sm_P,
unfold inverts_mat_def, rule exI[of _ P'], rule conjI)
show *: "P * P' = 1⇩m (dim_row P)"
by (metis PP'_1 True index_mult_mat(2))
show "P' * P = 1⇩m (dim_row P')"
proof (rule mat_mult_left_right_inverse)
show "P ∈ carrier_mat (dim_row P') (dim_row P')"
by (metis * P'_def PP'_1 True carrier_mat_triv index_one_mat(2) sm_P square_mat.elims(2))
show "P' ∈ carrier_mat (dim_row P') (dim_row P')"
by (metis P'_def True carrier_mat_triv)
show "P * P' = 1⇩m (dim_row P')"
by (metis P'_def PP'_1 True)
qed
qed
have inv_Q: "invertible_mat Q"
proof (unfold invertible_mat_def, rule conjI, rule sm_Q,
unfold inverts_mat_def, rule exI[of _ Q'], rule conjI)
show *: "Q * Q' = 1⇩m (dim_row Q)"
by (metis QQ'_1 True index_mult_mat(2))
show "Q' * Q = 1⇩m (dim_row Q')"
proof (rule mat_mult_left_right_inverse)
show 1: "Q ∈ carrier_mat (dim_row Q') (dim_row Q')"
by (metis Q'_def QQ'_1 True carrier_mat_triv dim_row_mat(1) index_mult_mat(2)
mat_of_rows_list_def sm_Q square_mat.simps)
thus "Q' ∈ carrier_mat (dim_row Q') (dim_row Q')"
by (metis * carrier_matD(1) carrier_mat_triv index_mult_mat(3) index_one_mat(3))
show "Q * Q' = 1⇩m (dim_row Q')" using * 1 by auto
qed
qed
have "P ∈ carrier_mat m m"
by (metis PP'_1 True carrier_matI index_mult_mat(2) sm_P square_mat.simps)
moreover have "Q ∈ carrier_mat n n"
by (metis QQ'_1 True carrier_matI index_mult_mat(2) sm_Q square_mat.simps)
ultimately show ?thesis unfolding is_SNF_def using inv_P inv_Q SNF_S S_PAQ A by auto
next
case False
hence "checker_SNF A = Smith_ED_mxn A"
using ext False c A
unfolding checker_SNF_def Let_def Code.abort_def
by (smt carrier_matD case_prod_conv dim_col_mat(1) mat_of_rows_list_def)
then show ?thesis using Smith_ED.is_SNF_Smith_mxn[OF A] c unfolding is_SNF_def
by auto
qed
qed
end